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

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 [] _ = []
......
......@@ -46,6 +46,7 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
import Class ( FunDep )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
Activation(..), RuleMatchInfo(..), defaultInlineSpec )
import DynFlags
......@@ -576,15 +577,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
-- Type classes
--
cl_decl :: { LTyClDecl RdrName }
: 'class' tycl_hdr fds where_cls
{% do { let { (binds, sigs, ats, docs) =
cvBindsAndSigs (unLoc $4)
; (ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms -- only type vars allowed
; checkKindSigs ats
; return $ L (comb4 $1 $2 $3 $4)
(mkClassDecl (ctxt, tc, tvs)
(unLoc $3) sigs binds ats docs) } }
: 'class' tycl_hdr fds where_cls {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 }
-- Type declarations (toplevel)
--
......@@ -598,87 +591,53 @@ ty_decl :: { LTyClDecl RdrName }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
{% do { (tc, tvs, _) <- checkSynHdr $2 False
; return (L (comb2 $1 $4)
(TySynonym tc tvs Nothing $4))
} }
{% mkTySynonym (comb2 $1 $4) False $2 $4 }
-- type family declarations
| 'type' 'family' type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
--
{% do { (tc, tvs, _) <- checkSynHdr $3 False
; return (L (comb3 $1 $3 $4)
(TyFamily TypeFamily tc tvs (unLoc $4)))
} }
{% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
-- type instance declarations
| 'type' 'instance' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
--
{% do { (tc, tvs, typats) <- checkSynHdr $3 True
; return (L (comb2 $1 $5)
(TySynonym tc tvs (Just typats) $5))
} }
{% mkTySynonym (comb2 $1 $5) True $3 $5 }
-- ordinary data type or newtype declaration
| data_or_newtype tycl_hdr constrs deriving
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms -- no type pattern
; return $!
sL (comb4 $1 $2 $3 $4)
{% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2
Nothing (reverse (unLoc $3)) (unLoc $4) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
(mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
Nothing (reverse (unLoc $3)) (unLoc $4)) } }
-- ordinary GADT declaration
| data_or_newtype tycl_hdr opt_kind_sig
'where' gadt_constrlist
deriving
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms -- can have type pats
; return $!
sL (comb4 $1 $2 $4 $5)
(mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
(unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
{% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2
(unLoc $3) (reverse (unLoc $5)) (unLoc $6) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
-- data/newtype family
| 'data' 'family' tycl_hdr opt_kind_sig
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
; checkTyVars tparms -- no type pattern
; unless (null (unLoc ctxt)) $ -- and no context
parseError (getLoc ctxt)
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $4)
(TyFamily DataFamily tc tvs (unLoc $4)) } }
| 'data' 'family' type opt_kind_sig
{% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
-- can have type pats
; return $
L (comb4 $1 $3 $4 $5)
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
(mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
Nothing (reverse (unLoc $4)) (unLoc $5)) } }
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
'where' gadt_constrlist
deriving
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
-- can have type pats
; return $
L (comb4 $1 $3 $6 $7)
(mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
(unLoc $4) (reverse (unLoc $6)) (unLoc $7)) } }
-- Associate type family declarations
{% mkTyData (comb4 $1 $3 $6 $7) (unLoc $1) True $3
(unLoc $4) (reverse (unLoc $6)) (unLoc $7) }
-- Associated type family declarations
--
-- * They have a different syntax than on the toplevel (no family special
-- identifier).
......@@ -692,68 +651,38 @@ at_decl_cls :: { LTyClDecl RdrName }
: 'type' type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
--
{% do { (tc, tvs, _) <- checkSynHdr $2 False
; return (L (comb3 $1 $2 $3)
(TyFamily TypeFamily tc tvs (unLoc $3)))
} }
{% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
-- default type instance
| 'type' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
--
{% do { (tc, tvs, typats) <- checkSynHdr $2 True
; return (L (comb2 $1 $4)
(TySynonym tc tvs (Just typats) $4))
} }
{% mkTySynonym (comb2 $1 $4) True $2 $4 }
-- data/newtype family declaration
| 'data' tycl_hdr opt_kind_sig
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms -- no type pattern
; unless (null (unLoc ctxt)) $ -- and no context
parseError (getLoc ctxt)
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $3)
(TyFamily DataFamily tc tvs (unLoc $3))
} }
-- Associate type instances
| 'data' type opt_kind_sig
{% mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) }
-- Associated type instances
--
at_decl_inst :: { LTyClDecl RdrName }
-- type instance declarations
: 'type' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
--
{% do { (tc, tvs, typats) <- checkSynHdr $2 True
; return (L (comb2 $1 $4)
(TySynonym tc tvs (Just typats) $4))
} }
{% mkTySynonym (comb2 $1 $4) True $2 $4 }
-- data/newtype instance declaration
| data_or_newtype tycl_hdr constrs deriving
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
-- can have type pats
; return $
L (comb4 $1 $2 $3 $4)
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
(mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
Nothing (reverse (unLoc $3)) (unLoc $4)) } }
{% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2
Nothing (reverse (unLoc $3)) (unLoc $4) }
-- GADT instance declaration
| data_or_newtype tycl_hdr opt_kind_sig
'where' gadt_constrlist
deriving
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
-- can have type pats
; return $
L (comb4 $1 $2 $5 $6)
(mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
(unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
{% mkTyData (comb4 $1 $2 $5 $6) (unLoc $1) True $2
(unLoc $3) (reverse (unLoc $5)) (unLoc $6) }
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
......@@ -770,12 +699,9 @@ opt_kind_sig :: { Located (Maybe Kind) }
-- (Eq a, Ord b) => T a b
-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
tycl_hdr :: { Located (LHsContext RdrName,
Located RdrName,
[LHsTyVarBndr RdrName],
[LHsType RdrName]) }
: context '=>' type {% checkTyClHdr $1 $3 >>= return.LL }
| type {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
tycl_hdr :: { Located (LHsContext RdrName, LHsType RdrName) }
: context '=>' type { LL ($1, $3) }
| type { L1 (noLoc [], $1) }
-----------------------------------------------------------------------------
-- Stand-alone deriving
......@@ -979,15 +905,12 @@ opt_asig :: { Maybe (LHsType RdrName) }
: {- empty -} { Nothing }
| '::' atype { Just $2 }
sigtypes1 :: { [LHsType RdrName] }
: sigtype { [ $1 ] }
| sigtype ',' sigtypes1 { $1 : $3 }
sigtype :: { LHsType RdrName }
sigtype :: { LHsType RdrName } -- Always a HsForAllTy,
-- to tell the renamer where to generalise
: ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
sigtypedoc :: { LHsType RdrName }
sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy
: ctypedoc { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
......@@ -995,6 +918,10 @@ sig_vars :: { Located [Located RdrName] }
: sig_vars ',' var { LL ($3 : unLoc $1) }
| var { L1 [$1] }
sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys
: sigtype { [ $1 ] }
| sigtype ',' sigtypes1 { $1 : $3 }
-----------------------------------------------------------------------------
-- Types
......@@ -1073,7 +1000,8 @@ btype :: { LHsType RdrName }
atype :: { LHsType RdrName }
: gtycon { L1 (HsTyVar (unLoc $1)) }
| tyvar { L1 (HsTyVar (unLoc $1)) }
| strict_mark atype { LL (HsBangTy (unLoc $1) $2) }
| strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only
| '{' fielddecls '}' { LL $ HsRecTy $2 } -- Constructor sigs only
| '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
| '[' ctype ']' { LL $ HsListTy $2 }
......@@ -1115,15 +1043,15 @@ tv_bndr :: { LHsTyVarBndr RdrName }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2)
(unLoc $4)) }
fds :: { Located [Located ([RdrName], [RdrName])] }
fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
| '|' fds1 { LL (reverse (unLoc $2)) }
fds1 :: { Located [Located ([RdrName], [RdrName])] }
fds1 :: { Located [Located (FunDep RdrName)] }
: fds1 ',' fd { LL ($3 : unLoc $1) }
| fd { L1 [$1] }
fd :: { Located ([RdrName], [RdrName]) }
fd :: { Located (FunDep RdrName) }
: varids0 '->' varids0 { L (comb3 $1 $2 $3)
(reverse (unLoc $1), reverse (unLoc $3)) }
......@@ -1165,21 +1093,11 @@ gadt_constrs :: { Located [LConDecl RdrName] }
gadt_constr :: { [LConDecl RdrName] }
: con_list '::' sigtype
{ map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) }
-- Syntax: Maybe merge the record stuff with the single-case above?
-- (to kill the mostly harmless reduce/reduce error)
-- XXX revisit audreyt
| constr_stuff_record '::' sigtype
{ let (con,details) = unLoc $1 in
[LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing)] }
{-
| forall context '=>' constr_stuff_record '::' sigtype
{ let (con,details) = unLoc $4 in
LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6) Nothing ) }
| forall constr_stuff_record '::' sigtype
{ let (con,details) = unLoc $2 in
LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4) Nothing) }
-}
-- Deprecated syntax for GADT record declarations
| oqtycon '{' fielddecls '}' '::' sigtype
{% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6
; return [cd] } }