Commit 432b9c93 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

New syntax for GADT-style record declarations, and associated refactoring

The main purpose of this patch is to fix Trac #3306, by fleshing out the
syntax for GADT-style record declraations so that you have a context in 
the type.  The new form is
   data T a where
     MkT :: forall a. Eq a => { x,y :: !a } -> T a
See discussion on the Trac ticket.

The old form is still allowed, but give a deprecation warning.

When we remove the old form we'll also get rid of the one reduce/reduce
error in the grammar. Hurrah!

While I was at it, I failed as usual to resist the temptation to do lots of
refactoring.  The parsing of data/type declarations is now much simpler and
more uniform.  Less code, less chance of errors, and more functionality.
Took longer than I planned, though.

ConDecl has record syntax, but it was not being used consistently, so I
pushed that through the compiler.
parent 25cead29
......@@ -372,14 +372,14 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
-------------------------------------------------------
repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L _ (ConDecl con _ [] (L _ []) details ResTyH98 _))
repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
, con_details = details, con_res = ResTyH98 }))
= do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
; repConstr con1 details
}
repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
= addTyVarBinds tvs $ \bndrs ->
do { c' <- repC (L loc (ConDecl con expl [] (L cloc []) details
ResTyH98 doc))
do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
; ctxt' <- repContext ctxt
; bndrs' <- coreList tyVarBndrTyConName bndrs
; rep2 forallCName [unC bndrs', unC ctxt', unC c']
......
......@@ -115,31 +115,37 @@ cvtTop (TH.SigD nm typ)
; returnL $ Hs.SigD (TypeSig nm' ty') }
cvtTop (TySynD tc tvs rhs)
= do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
cvtTop (DataD ctxt tc tvs constrs derivs)
= do { stuff <- cvt_tycl_hdr ctxt tc tvs
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }
; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = cons', tcdDerivs = derivs' }) }
cvtTop (NewtypeD ctxt tc tvs constr derivs)
= do { stuff <- cvt_tycl_hdr ctxt tc tvs
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') }
; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = [con'], tcdDerivs = derivs'}) }
cvtTop (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
; let (ats, bind_sig_decs) = partition isFamilyD decs
; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
; ats' <- mapM cvtTop ats
; let ats'' = map unTyClD ats'
; returnL $
TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' ats'' []
TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
, tcdATs = ats'', tcdDocs = [] }
-- no docs in TH ^^
}
where
......@@ -174,7 +180,7 @@ cvtTop (PragmaD prag)
}
cvtTop (FamilyD flav tc tvs kind)
= do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; let kind' = fmap cvtKind kind
; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind')
}
......@@ -183,17 +189,21 @@ cvtTop (FamilyD flav tc tvs kind)
cvtFamFlavour DataFam = DataFamily
cvtTop (DataInstD ctxt tc tys constrs derivs)
= do { stuff <- cvt_tyinst_hdr ctxt tc tys
= do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs')
; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = cons', tcdDerivs = derivs' })
}
cvtTop (NewtypeInstD ctxt tc tys constr derivs)
= do { stuff <- cvt_tyinst_hdr ctxt tc tys
= do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs')
; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
, tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
, tcdCons = [con'], tcdDerivs = derivs' })
}
cvtTop (TySynInstD tc tys rhs)
......@@ -210,13 +220,12 @@ unTyClD _ = panic "Convert.unTyClD: internal error"
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
-> CvtM ( LHsContext RdrName
, Located RdrName
, [LHsTyVarBndr RdrName]
, Maybe [LHsType RdrName])
, [LHsTyVarBndr RdrName])
cvt_tycl_hdr cxt tc tvs
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
; return (cxt', tc', tvs', Nothing)
; return (cxt', tc', tvs')
}
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
......@@ -259,20 +268,20 @@ cvtConstr (NormalC c strtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; tys' <- mapM cvt_arg strtys
; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys
; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c
; cxt' <- returnL []
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
= cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
......@@ -282,8 +291,8 @@ cvtConstr (ForallC tvs ctxt con)
; tvs' <- cvtTvs tvs
; ctxt' <- cvtContext ctxt
; case con' of
ConDecl l _ [] (L _ []) x ResTyH98 _
-> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
ConDecl { con_qvars = [], con_cxt = L _ [] }
-> returnL $ con' { con_qvars = tvs', con_cxt = ctxt' }
_ -> panic "ForallC: Can't happen" }
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
......
......@@ -41,7 +41,7 @@ module HsDecls (
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl, ResType(..), ConDeclField(..),
ConDecl(..), LConDecl, ResType(..),
HsConDeclDetails, hsConDeclArgTys, hsConDeclsNames,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
......@@ -704,9 +704,8 @@ data ConDecl name
-- ^ Type variables. Depending on 'con_res' this describes the
-- follewing entities
--
-- - ResTyH98: the constructor's existential type variables
--
-- - ResTyGADT: all the constructor's quantified type variables
-- - 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
......@@ -720,6 +719,12 @@ data ConDecl name
, con_doc :: Maybe (LHsDoc name)
-- ^ A possible Haddock comment.
, con_old_rec :: Bool
-- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
-- GADT-style record decl C { blah } :: T a b
-- Remove this when we no longer parse this stuff, and hence do not
-- need to report decprecated use
}
type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
......@@ -729,15 +734,15 @@ hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map cd_fld_type flds
data ConDeclField name -- Record fields have Haddoc docs on them
= ConDeclField { cd_fld_name :: Located name,
cd_fld_type :: LBangType name,
cd_fld_doc :: Maybe (LHsDoc name) }
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
instance OutputableBndr name => Outputable (ResType name) where
-- Debugging only
ppr ResTyH98 = ptext (sLit "ResTyH98")
ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
\end{code}
\begin{code}
......@@ -764,33 +769,31 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = ResTyH98, con_doc = doc })
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
where
ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields
ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _)
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = PrefixCon arg_tys
, con_res = ResTyGADT res_ty })
= ppr con <+> dcolon <+>
sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
where
mk_fun_ty a b = noLoc (HsFunTy a b)
pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
= sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty]
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
= sep [ppr con <+> dcolon <+> pprHsForAll expl tvs cxt,
pprConDeclFields fields <+> arrow <+> ppr res_ty]
pprConDecl (ConDecl con _expl _tvs _cxt (InfixCon _ _) (ResTyGADT _res_ty) _)
pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyGADT {} })
= pprPanic "pprConDecl" (ppr con)
-- In GADT syntax we don't allow infix constructors
ppr_fields :: OutputableBndr name => [ConDeclField name] -> SDoc
ppr_fields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty,
cd_fld_doc = doc })
= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
\end{code}
%************************************************************************
......
......@@ -15,6 +15,8 @@ module HsTypes (
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
ConDeclField(..), pprConDeclFields,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames, replaceTyVarName,
......@@ -118,8 +120,6 @@ data HsType name
| HsTyVar name -- Type variable or type constructor
| HsBangTy HsBang (LHsType name) -- Bang-style type annotations
| HsAppTy (LHsType name)
(LHsType name)
......@@ -159,8 +159,19 @@ data HsType name
| HsDocTy (LHsType name) (LHsDoc name) -- A documented type
| HsBangTy HsBang (LHsType name) -- Bang-style type annotations
| HsRecTy [ConDeclField name] -- Only in data type declarations
data HsExplicitForAll = Explicit | Implicit
data ConDeclField name -- Record fields have Haddoc docs on them
= ConDeclField { cd_fld_name :: Located name,
cd_fld_type :: LBangType name,
cd_fld_doc :: Maybe (LHsDoc name) }
-----------------------
-- Combine adjacent for-alls.
-- The following awkward situation can happen otherwise:
......@@ -310,6 +321,13 @@ pprHsContext cxt = ppr_hs_context cxt <+> ptext (sLit "=>")
ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc
ppr_hs_context [] = empty
ppr_hs_context cxt = parens (interpp'SP cxt)
pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty,
cd_fld_doc = doc })
= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
\end{code}
\begin{code}
......@@ -352,6 +370,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr ty
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar name) = ppr name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2
ppr_mono_ty _ (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
......
......@@ -151,17 +151,16 @@ parseKey key toParse0 =
-- -----------------------------------------------------------------------------
-- Adding documentation to record fields (used in parsing).
type Field a = ([Located a], LBangType a, Maybe (LHsDoc a))
addFieldDoc :: ConDeclField a -> Maybe (LHsDoc a) -> ConDeclField a
addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }
addFieldDoc :: Field a -> Maybe (LHsDoc a) -> Field a
addFieldDoc (a, b, c) doc = (a, b, c `mplus` doc)
addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field a]
addFieldDocs :: [ConDeclField a] -> Maybe (LHsDoc a) -> [ConDeclField a]
addFieldDocs [] _ = []
addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
addConDoc decl Nothing = decl
addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
addConDocs [] _ = []
......
This diff is collapsed.
......@@ -124,18 +124,18 @@ tdefs :: { [TyClDecl RdrName] }
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
{ mkTyData DataType ( noLoc []
, noLoc (ifaceExtRdrName $2)
, map toHsTvBndr $3
, Nothing
) Nothing $6 Nothing }
{ TyData { tcdND = DataType, tcdCtxt = noLoc []
, tcdLName = noLoc (ifaceExtRdrName $2)
, tcdTyVars = map toHsTvBndr $3
, tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = $6, tcdDerivs = Nothing } }
| '%newtype' q_tc_name tv_bndrs trep ';'
{ let tc_rdr = ifaceExtRdrName $2 in
mkTyData NewType ( noLoc []
, noLoc tc_rdr
, map toHsTvBndr $3
, Nothing
) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
TyData { tcdND = NewType, tcdCtxt = noLoc []
, tcdLName = noLoc tc_rdr
, tcdTyVars = map toHsTvBndr $3
, tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = Nothing } }
-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
......@@ -143,8 +143,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) Explicit []
(noLoc []) con_info ResTyH98 Nothing]) }
in [noLoc $ mkSimpleConDecl (noLoc dc_name) []
(noLoc []) con_info]) }
cons :: { [LConDecl RdrName] }
: {- empty -} { [] } -- 20060420 Empty data types allowed. jds
......@@ -153,15 +153,8 @@ cons :: { [LConDecl RdrName] }
con :: { LConDecl RdrName }
: d_pat_occ attv_bndrs hs_atys
{ noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98 Nothing }
| d_pat_occ '::' ty
-- XXX - audreyt - $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) Nothing }
{ noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) }
-- ToDo: parse record-style declarations
attv_bndrs :: { [LHsTyVarBndr RdrName] }
: {- empty -} { [] }
......
This diff is collapsed.
......@@ -65,6 +65,7 @@ extractHsTyNames ty
get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
get (HsParTy ty) = getl ty
get (HsBangTy _ ty) = getl ty
get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds)
get (HsNumTy _) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsSpliceTy _) = emptyNameSet -- Type splices mention no type variables
......
......@@ -16,7 +16,7 @@ import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
......@@ -647,15 +647,15 @@ rnTyClDecl (tydecl@TyFamily {}) =
rnFamily tydecl bindTyVarsRn
-- "data", "newtype", "data instance, and "newtype instance" declarations
rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdCons = condecls,
tcdKindSig = sig, tcdDerivs = derivs})
tcdKindSig = sig, tcdDerivs = derivs}
| is_vanilla -- Normal Haskell data type decl
= ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
-- data type is syntactically illegal
do { tyvars <- pruneTyVars tydecl
; bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
-- data type is syntactically illegal
ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct
do { bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
{ tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
......@@ -719,10 +719,10 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
return (Just ds', extractHsTyNames_s ds')
-- "type" and "type instance" declarations
rnTyClDecl tydecl@(TySynonym {tcdLName = name,
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
= do { tyvars <- pruneTyVars tydecl
; bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
= ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct
do { bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
{ name' <- if isFamInstDecl tydecl
then lookupLocatedOccRn name -- may be imported family
else lookupLocatedTopBndrRn name
......@@ -801,6 +801,13 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
distinctTyVarBndrs :: [LHsTyVarBndr RdrName] -> Bool
-- The tyvar binders should have distinct names
distinctTyVarBndrs tvs
= null (findDupsEq eq tvs)
where
eq (L _ v1) (L _ v2) = hsTyVarName v1 == hsTyVarName v2
badGadtStupidTheta :: Located RdrName -> SDoc
badGadtStupidTheta _
= vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
......@@ -815,37 +822,6 @@ badGadtStupidTheta _
%*********************************************************
\begin{code}
-- Remove any duplicate type variables in family instances may have non-linear
-- left-hand sides. Complain if any, but the first occurence of a type
-- variable has a user-supplied kind signature.
--
pruneTyVars :: TyClDecl RdrName -> RnM [LHsTyVarBndr RdrName]
pruneTyVars tydecl
| isFamInstDecl tydecl
= do { let pruned_tyvars = nubBy eqLTyVar tyvars
; assertNoSigsInRepeats tyvars
; return pruned_tyvars
}
| otherwise
= return tyvars
where
tyvars = tcdTyVars tydecl
assertNoSigsInRepeats [] = return ()
assertNoSigsInRepeats (tv:tvs)
= do { let offending_tvs = [ tv' | tv'@(L _ (KindedTyVar _ _)) <- tvs
, tv' `eqLTyVar` tv]
; checkErr (null offending_tvs) $
illegalKindSig (head offending_tvs)
; assertNoSigsInRepeats tvs
}
illegalKindSig tv
= hsep [ptext (sLit "Repeat variable occurrence may not have a"),
ptext (sLit "kind signature:"), quotes (ppr tv)]
tv1 `eqLTyVar` tv2 = hsLTyVarLocName tv1 `eqLocated` hsLTyVarLocName tv2
-- Although, we are processing type patterns here, all type variables will
-- already be in scope (they are the same as in the 'tcdTyVars' field of the
-- type declaration to which these patterns belong)
......@@ -859,8 +835,12 @@ rnConDecls _tycon condecls
= mapM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = res_ty, con_doc = mb_doc
, con_old_rec = old_rec, con_explicit = expl })
= do { addLocM checkConName name
; when old_rec (addWarn (deprecRecSyntax decl))
; new_name <- lookupLocatedTopBndrRn name
; name_env <- getLocalRdrEnv
......@@ -871,20 +851,21 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc
arg_tys = hsConDeclArgTys details
implicit_tvs = case res_ty of
ResTyH98 -> filter not_in_scope $
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
new_tvs = case expl of
Explicit -> tvs
Implicit -> userHsTyVarBndrs implicit_tvs
; mb_doc' <- rnMbLHsDoc mb_doc
; mb_doc' <- rnMbLHsDoc mb_doc
; bindTyVarsRn doc tvs' $ \new_tyvars -> do
; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
; new_details <- rnConDeclDetails doc details
; new_details <- rnConDeclDetails doc details
; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
, con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
......@@ -895,15 +876,22 @@ rnConResult :: SDoc
-> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
ResType Name)
rnConResult _ details ResTyH98 = return (details, ResTyH98)
rnConResult doc details (ResTyGADT ty) = do
ty' <- rnHsSigType doc ty
let (arg_tys, res_ty) = splitHsFunType ty'
-- We can split it up, now the renamer has dealt with fixities
case details of
PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
RecCon _ -> return (details, ResTyGADT ty')
InfixCon {} -> panic "rnConResult"
rnConResult doc details (ResTyGADT ty)
= do { ty' <- rnLHsType doc ty
; let (arg_tys, res_ty) = splitHsFunType ty'
-- We can finally split it up,
-- now the renamer has dealt with fixities
-- See Note [Sorting out the result type] in RdrHsSyn
details' = case details of
RecCon {} -> details
PrefixCon {} -> PrefixCon arg_tys
InfixCon {} -> pprPanic "rnConResult" (ppr ty)
-- See Note [Sorting out the result type] in RdrHsSyn
; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
(addErr (badRecResTy doc))
; return (details', ResTyGADT res_ty) }
rnConDeclDetails :: SDoc
-> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
......@@ -918,18 +906,11 @@ rnConDeclDetails doc (InfixCon ty1 ty2)
return (InfixCon new_ty1 new_ty2)
rnConDeclDetails doc (RecCon fields)
= do { new_fields <- mapM (rnField doc) fields
= do { new_fields <- rnConDeclFields doc fields
-- No need to check for duplicate fields
-- since that is done by RnNames.extendGlobalRdrEnvRn
; return (RecCon new_fields) }
rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
rnField doc (ConDeclField name ty haddock_doc)
= lookupLocatedTopBndrRn name `thenM` \ new_name ->
rnLHsType doc ty `thenM` \ new_ty ->
rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc ->
return (ConDeclField new_name new_ty new_haddock_doc)
-- Rename family declarations
--
-- * This function is parametrised by the routine handling the index
......@@ -1005,6 +986,16 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
| rdrName == hsTyVarName tv = True
| otherwise = rdrName `ltvElem` ltvs
deprecRecSyntax :: ConDecl RdrName -> SDoc
deprecRecSyntax decl
= vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
<+> ptext (sLit "uses deprecated syntax")
, ptext (sLit "Instead, use the form")
, nest 2 (ppr decl) ] -- Pretty printer uses new form
badRecResTy :: SDoc -> SDoc
badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
noPatterns :: SDoc
noPatterns = text "Default definition for an associated synonym cannot have"
<+> text "type pattern"
......
......@@ -7,7 +7,7 @@
module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsSigType, rnHsTypeFVs,
rnHsSigType, rnHsTypeFVs, rnConDeclFields,
-- Precence related stuff
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
......@@ -23,7 +23,7 @@ import DynFlags
import HsSyn
import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn ( extractHsTyNames )
import RnHsDoc ( rnLHsDoc )
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import TcRnMonad
import RdrName
......@@ -128,9 +128,13 @@ rnHsType doc (HsParTy ty) = do
ty' <- rnLHsType doc ty
return (HsParTy ty')
rnHsType doc (HsBangTy b ty) = do
ty' <- rnLHsType doc ty
return (HsBangTy b ty')
rnHsType doc (HsBangTy b ty)
= do { ty' <- rnLHsType doc ty
; return (HsBangTy b ty') }
rnHsType doc (HsRecTy flds)
= do { flds' <- rnConDeclFields doc flds
; return (HsRecTy flds') }
rnHsType _ (HsNumTy i)
| i == 1 = return (HsNumTy i)
......@@ -213,6 +217,16 @@ rnForAll doc exp forall_tyvars ctxt ty
return (HsForAllTy exp new_tyvars new_ctxt new_ty)
-- Retain the same implicit/explicit flag as before
-- so that we can later print it correctly
rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
rnConDeclFields doc fields = mapM (rnField doc) fields
rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
rnField doc (ConDeclField name ty haddock_doc)
= do { new_name <- lookupLocatedTopBndrRn name
; new_ty <- rnLHsType doc ty
; new_haddock_doc <- rnMbLHsDoc haddock_doc
; return (ConDeclField new_name new_ty new_haddock_doc) }
\end{code}
%*********************************************************
......
......@@ -404,9 +404,14 @@ kc_hs_type (HsForAllTy exp tv_names context ty)
; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) }
kc_hs_type (HsBangTy b ty) = do
(ty', kind) <- kc_lhs_type ty
return (HsBangTy b ty', kind)
kc_hs_type (HsBangTy b ty)
= do { (ty', kind) <- kc_lhs_type ty
; return (HsBangTy b ty', kind) }
kc_hs_type ty@(HsRecTy _)
= failWithTc (ptext (sLit "Unexpected record type") <+> ppr ty)
-- Record types (which only show up temporarily in constructor signatures)
-- should have been removed by now
#ifdef GHCI /* Only if bootstrapped */
kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
......@@ -554,9 +559,12 @@ ds_type ty@(HsTyVar _)
ds_type (HsParTy ty) -- Remove the parentheses markers
= dsHsType ty
ds_type ty@(HsBangTy _ _) -- No bangs should be here
ds_type ty@(HsBangTy {}) -- No bangs should be here
= failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
ds_type ty@(HsRecTy {}) -- No bangs should be here
= failWithTc (ptext (sLit "Unexpected record type:") <+> ppr ty)
ds_type (HsKindSig ty _)
= dsHsType ty -- Kind checking done already
......
......@@ -590,7 +590,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
where
-- doc comments are typechecked to Nothing here
kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _)
kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
, con_cxt = ex_ctxt, con_details = details, con_res = res })
= addErrCtxt (dataConCtxt name) $
kcHsTyVars ex_tvs $ \ex_tvs' -> do
do { ex_ctxt' <- kcHsContext ex_ctxt
......@@ -598,7 +599,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
; res' <- case res of
ResTyH98 -> return ResTyH98
ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) }
; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
, con_details = details', con_res = res' }) }
kc_con_details (PrefixCon btys)
= do { btys' <- mapM kc_larg_ty btys
......@@ -829,7 +831,8 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields
-> TcM DataCon
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
(ConDecl name _ tvs ctxt details res_ty _)
(ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
, con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
......
......@@ -2364,14 +2364,34 @@ In this example we give a single signature for <literal>T1</literal> and <litera
<listitem><para>
The type signature of
each constructor is independent, and is implicitly universally quantified as usual.
Different constructors may have different universally-quantified type variables
and different type-class constraints.
For example, this is fine:
In particular, the type variable(s) in the "<literal>data T a where</literal>" header
have no scope, and different constructors may have different universally-quantified type variables:
<programlisting>
data T a where -- The 'a' has no scope
T1,T2 :: b -> T b -- Means forall b. b -> T b
T3 :: T a -- Means forall a. T a
</programlisting>
</para></listitem>
<listitem><para>
A constructor signature may mention type class constraints, which can differ for
different constructors. For example, this is fine:
<programlisting>
data T a where
T1 :: Eq b => b -> T b
T1 :: Eq b => b -> b -> T b
T2 :: (Show c, Ix c) => c -> [c] -> T c
</programlisting>
When patten matching, these constraints are made available to discharge constraints
in the body of the match. For example:
<programlisting>
f :: T a -> String
f (T1 x y) | x==y = "yes"