-------------------------------------------------------
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']
; 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
}
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')
}
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)
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]
= 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')
; 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)
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
-- ** Data-constructor declarations
- ConDecl(..), LConDecl, ResType(..), ConDeclField(..),
+ ConDecl(..), LConDecl, ResType(..),
HsConDeclDetails, hsConDeclArgTys, hsConDeclsNames,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ^ 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
, 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]
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}
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}
%************************************************************************
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
+
+ ConDeclField(..), pprConDeclFields,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames, replaceTyVarName,
| HsTyVar name -- Type variable or type constructor
- | HsBangTy HsBang (LHsType name) -- Bang-style type annotations
-
| HsAppTy (LHsType name)
(LHsType 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:
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}
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)
-- -----------------------------------------------------------------------------
-- 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 [] _ = []
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
-- 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)
--
--
-- 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).
: '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 }
-- (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
: {- 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
: sig_vars ',' var { LL ($3 : unLoc $1) }
| var { L1 [$1] }
+sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys
+ : sigtype { [ $1 ] }
+ | sigtype ',' sigtypes1 { $1 : $3 }
+
-----------------------------------------------------------------------------
-- Types
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 }
| '(' 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)) }
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] } }
constrs :: { Located [LConDecl RdrName] }
: {- empty; a GHC extension -} { noLoc [] }
constr :: { LConDecl RdrName }
: maybe_docnext forall context '=>' constr_stuff maybe_docprev
{ let (con,details) = unLoc $5 in
- L (comb4 $2 $3 $4 $5) (ConDecl con Explicit (unLoc $2) $3 details ResTyH98 ($1 `mplus` $6)) }
+ addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con (unLoc $2) $3 details))
+ ($1 `mplus` $6) }
| maybe_docnext forall constr_stuff maybe_docprev
{ let (con,details) = unLoc $3 in
- L (comb2 $2 $3) (ConDecl con Explicit (unLoc $2) (noLoc []) details ResTyH98 ($1 `mplus` $4)) }
+ addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con (unLoc $2) (noLoc []) details))
+ ($1 `mplus` $4) }
forall :: { Located [LHsTyVarBndr RdrName] }
: 'forall' tv_bndrs '.' { LL $2 }
-- C t1 t2 %: D Int
-- in which case C really would be a type constructor. We can't resolve this
-- ambiguity till we come across the constructor oprerator :% (or not, more usually)
- : btype {% mkPrefixCon $1 [] >>= return.LL }
- | oqtycon '{' '}' {% mkRecCon $1 [] >>= return.LL }
- | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL }
- | btype conop btype { LL ($2, InfixCon $1 $3) }
-
-constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) }
- : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
- | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
-
-fielddecls :: { [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] }
- : fielddecl maybe_docnext ',' maybe_docprev fielddecls { addFieldDoc (unLoc $1) $4 : addFieldDocs $5 $2 }
- | fielddecl { [unLoc $1] }
-
-fielddecl :: { Located ([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName)) }
- : maybe_docnext sig_vars '::' ctype maybe_docprev { L (comb3 $2 $3 $4) (reverse (unLoc $2), $4, $1 `mplus` $5) }
+ : btype {% splitCon $1 >>= return.LL }
+ | btype conop btype { LL ($2, InfixCon $1 $3) }
+
+fielddecls :: { [ConDeclField RdrName] }
+ : {- empty -} { [] }
+ | fielddecls1 { $1 }
+
+fielddecls1 :: { [ConDeclField RdrName] }
+ : fielddecl maybe_docnext ',' maybe_docprev fielddecls1
+ { [ addFieldDoc f $4 | f <- $1 ] ++ addFieldDocs $5 $2 }
+ -- This adds the doc $4 to each field separately
+ | fielddecl { $1 }
+
+fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int
+ : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld $4 ($1 `mplus` $5)
+ | fld <- reverse (unLoc $2) ] }
-- We allow the odd-looking 'inst_type' in a deriving clause, so that
-- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
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
: {- 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
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 -} { [] }
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl,
+ mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice,
- mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
+ mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
+ splitCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
cvBindGroup,
-- -> P RdrNameHsDecl
mkExtName, -- RdrName -> CLabelString
mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
+ mkSimpleConDecl,
+ mkDeprecatedGadtRecordDecl,
-- 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, -- LHsContext RdrName -> LHsType RdrName
- -- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
checkTyVars, -- [LHsType RdrName] -> P ()
- checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
checkKindSigs, -- [LTyClDecl RdrName] -> P ()
checkInstType, -- HsType -> P HsType
checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
import FastString
import List ( isSuffixOf, nubBy )
-import Monad ( unless )
#include "HsVersions.h"
\end{code}
extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
+extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
+extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
+
extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
-- This one takes the context and tau-part of a
-- sigma type and returns their free type variables
extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
-extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys
+extract_pred (HsClassP _ tys) acc = extract_ltys tys acc
extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
+extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
+extract_ltys tys acc = foldr extract_lty acc tys
+
extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
extract_lty (L loc ty) acc
= case ty of
HsTyVar tv -> extract_tv loc tv acc
HsBangTy _ ty -> extract_lty ty acc
+ HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsListTy ty -> extract_lty ty acc
HsPArrTy ty -> extract_lty ty acc
- HsTupleTy _ tys -> foldr extract_lty acc tys
+ HsTupleTy _ tys -> extract_ltys tys acc
HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsPredTy p -> extract_pred p acc
HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
- -> [Located (FunDep name)]
- -> [LSig name]
- -> LHsBinds name
- -> [LTyClDecl name]
- -> [LDocDecl name]
- -> TyClDecl name
-mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
- = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
- tcdFDs = fds,
- tcdSigs = sigs,
- tcdMeths = mbinds,
- tcdATs = ats,
- tcdDocs = docs
- }
-
-mkTyData :: NewOrData
- -> (LHsContext name,
- Located name,
- [LHsTyVarBndr name],
- Maybe [LHsType name])
+mkClassDecl :: SrcSpan
+ -> Located (LHsContext RdrName, LHsType RdrName)
+ -> Located [Located (FunDep RdrName)]
+ -> Located (OrdList (LHsDecl RdrName))
+ -> P (LTyClDecl RdrName)
+
+mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
+ = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
+ ; (cls, tparams) <- checkTyClHdr tycl_hdr
+ ; tyvars <- checkTyVars tparams -- Only type vars allowed
+ ; checkKindSigs ats
+ ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
+ tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
+ tcdATs = ats, tcdDocs = docs })) }
+
+mkTyData :: SrcSpan
+ -> NewOrData
+ -> Bool -- True <=> data family instance
+ -> Located (LHsContext RdrName, LHsType RdrName)
-> Maybe Kind
- -> [LConDecl name]
- -> Maybe [LHsType name]
- -> TyClDecl name
-mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
- = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
- tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
- tcdKindSig = ksig, tcdDerivs = maybe_deriv }
+ -> [LConDecl RdrName]
+ -> Maybe [LHsType RdrName]
+ -> P (LTyClDecl RdrName)
+mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
+ = do { (tc, tparams) <- checkTyClHdr tycl_hdr
+
+ ; (tyvars, typats) <- checkTParams is_family tparams
+ ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
+ tcdTyVars = tyvars, tcdTyPats = typats,
+ tcdCons = data_cons,
+ tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
+
+mkTySynonym :: SrcSpan
+ -> Bool -- True <=> type family instances
+ -> LHsType RdrName -- LHS
+ -> LHsType RdrName -- RHS
+ -> P (LTyClDecl RdrName)
+mkTySynonym loc is_family lhs rhs
+ = do { (tc, tparams) <- checkTyClHdr lhs
+ ; (tyvars, typats) <- checkTParams is_family tparams
+ ; return (L loc (TySynonym tc tyvars typats rhs)) }
+
+mkTyFamily :: SrcSpan
+ -> FamilyFlavour
+ -> LHsType RdrName -- LHS
+ -> Maybe Kind -- Optional kind signature
+ -> P (LTyClDecl RdrName)
+mkTyFamily loc flavour lhs ksig
+ = do { (tc, tparams) <- checkTyClHdr lhs
+ ; tyvars <- checkTyVars tparams
+ ; return (L loc (TyFamily flavour tc tyvars ksig)) }
\end{code}
%************************************************************************
\begin{code}
-----------------------------------------------------------------------------
--- mkPrefixCon
+-- splitCon
-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.
-mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
- -> P (Located RdrName, HsConDeclDetails RdrName)
-mkPrefixCon ty tys
- = split ty tys
+splitCon :: LHsType RdrName
+ -> P (Located RdrName, HsConDeclDetails RdrName)
+-- This gets given a "type" that should look like
+-- C Int Bool
+-- or C { x::Int, y::Bool }
+-- and returns the pieces
+splitCon ty
+ = split ty []
where
split (L _ (HsAppTy t u)) ts = split t (u : ts)
split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
- return (data_con, PrefixCon ts)
- split (L l _) _ = parseError l "parse error in data/newtype declaration"
+ return (data_con, mk_rest ts)
+ split (L l _) _ = parseError l "parse error in data/newtype declaration"
+
+ mk_rest [L _ (HsRecTy flds)] = RecCon flds
+ mk_rest ts = PrefixCon ts
+
+mkDeprecatedGadtRecordDecl :: SrcSpan
+ -> Located RdrName
+ -> [ConDeclField RdrName]
+ -> LHsType RdrName
+ -> P (LConDecl RdrName)
+-- This one uses the deprecated syntax
+-- C { x,y ::Int } :: T a b
+-- We give it a RecCon details right away
+mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
+ = do { data_con <- tyConToDataCon con_loc con
+ ; return (L loc (ConDecl { con_old_rec = True
+ , con_name = data_con
+ , con_explicit = Implicit
+ , con_qvars = []
+ , con_cxt = noLoc []
+ , con_details = RecCon flds
+ , con_res = ResTyGADT res_ty
+ , con_doc = Nothing })) }
+
+mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
+ -> LHsContext RdrName -> HsConDeclDetails RdrName
+ -> ConDecl RdrName
+
+mkSimpleConDecl name qvars cxt details
+ = ConDecl { con_old_rec = False
+ , con_name = name
+ , con_explicit = Explicit
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = details
+ , con_res = ResTyH98
+ , con_doc = Nothing }
-mkRecCon :: Located RdrName ->
- [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
- P (Located RdrName, HsConDeclDetails RdrName)
-mkRecCon (L loc con) fields
- = do data_con <- tyConToDataCon loc con
- return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
+mkGadtDecl :: [Located RdrName]
+ -> LHsType RdrName -- Always a HsForAllTy
+ -> [ConDecl RdrName]
+-- We allow C,D :: ty
+-- and expand it as if it had been
+-- C :: ty; D :: ty
+-- (Just like type signatures in general.)
+mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
+ = [mk_gadt_con name | name <- names]
+ where
+ (details, res_ty) -- See Note [Sorting out the result type]
+ = case tau of
+ L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty)
+ _other -> (PrefixCon [], tau)
+
+ mk_gadt_con name
+ = ConDecl { con_old_rec = False
+ , con_name = name
+ , con_explicit = imp
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = details
+ , con_res = ResTyGADT res_ty
+ , con_doc = Nothing }
+mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
extra | tc == forall_tv_RDR
= text "Perhaps you intended to use -XExistentialQuantification"
| otherwise = empty
+\end{code}
+
+Note [Sorting out the result type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a GADT declaration which is not a record, we put the whole constr
+type into the ResTyGADT for now; the renamer will unravel it once it
+has sorted out operator fixities. Consider for example
+ C :: a :*: b -> a :*: b -> a :+: b
+Initially this type will parse as
+ a :*: (b -> (a :*: (b -> (a :+: b))))
+
+so it's hard to split up the arguments until we've done the precedence
+resolution (in the renamer) On the other hand, for a record
+ { x,y :: Int } -> a :*: b
+there is no doubt. AND we need to sort records out so that
+we can bring x,y into scope. So:
+ * For PrefixCon we keep all the args in the ResTyGADT
+ * For RecCon we do not
+\begin{code}
----------------------------------------------------------------------------
-- Various Syntactic Checks
check (HsParTy t) args = check (unLoc t) args
check _ _ = parseError spn "Malformed instance header"
+checkTParams :: Bool -- Type/data family
+ -> [LHsType RdrName]
+ -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
+-- checkTParams checks the type parameters of a data/newtype declaration
+-- There are two cases:
+--
+-- a) Vanilla data/newtype decl. In that case
+-- - the type parameters should all be type variables
+-- - they may have a kind annotation
+--
+-- b) Family data/newtype decl. In that case
+-- - The type parameters may be arbitrary types
+-- - We find the type-varaible binders by find the
+-- free type vars of those types
+-- - We make them all kind-sig-free binders (UserTyVar)
+-- If there are kind sigs in the type parameters, they
+-- will fix the binder's kind when we kind-check the
+-- type parameters
+checkTParams is_family tparams
+ | not is_family -- Vanilla case (a)
+ = do { tyvars <- checkTyVars tparams
+ ; return (tyvars, Nothing) }
+ | otherwise -- Family case (b)
+ = do { let tyvars = [L l (UserTyVar tv)
+ | L l tv <- extractHsTysRdrTyVars tparams]
+ ; return (tyvars, Just tparams) }
+
+checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature). If the second argument is `False',
-- only type variables are allowed and we raise an error on encountering a
-- non-variable; otherwise, we allow non-variable arguments and return the
-- entire list of parameters.
---
-checkTyVars :: [LHsType RdrName] -> P ()
-checkTyVars tparms = mapM_ chk tparms
+checkTyVars tparms = mapM chk tparms
where
-- Check that the name space is correct!
- chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
- | isRdrTyVar tv = return ()
- chk (L _ (HsTyVar tv))
- | isRdrTyVar tv = return ()
+ chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+ chk (L l (HsTyVar tv))
+ | isRdrTyVar tv = return (L l (UserTyVar tv))
chk (L l _) =
parseError l "Type found where type variable expected"
--- Check whether the type arguments in a type synonym head are simply
--- variables. If not, we have a type family instance and return all patterns.
--- If yes, we return 'Nothing' as the third component to indicate a vanilla
--- type synonym.
---
-checkSynHdr :: LHsType RdrName
- -> Bool -- is type instance?
- -> P (Located RdrName, -- head symbol
- [LHsTyVarBndr RdrName], -- parameters
- [LHsType RdrName]) -- type patterns
-checkSynHdr ty isTyInst =
- do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
- ; unless isTyInst $ checkTyVars tparms
- ; return (tc, tvs, tparms) }
-
-
+checkTyClHdr :: LHsType RdrName
+ -> P (Located RdrName, -- the head symbol (type or class name)
+ [LHsType RdrName]) -- parameters of head symbol
-- Well-formedness check and decomposition of type and class heads.
---
-checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
- -> P (LHsContext RdrName, -- the type context
- Located RdrName, -- the head symbol (type or class name)
- [LHsTyVarBndr RdrName], -- free variables of the non-context part
- [LHsType RdrName]) -- parameters of head symbol
--- The header of a type or class decl should look like
--- (C a, D b) => T a b
--- or T a b
--- or a + b
--- etc
--- With associated types, we can also have non-variable parameters; ie,
--- T Int [a]
--- or Int :++: [a]
--- The unaltered parameter list is returned in the fourth component of the
--- result. Eg, for
--- T Int [a]
--- we return
--- ('()', 'T', ['a'], ['Int', '[a]'])
-checkTyClHdr (L l cxt) ty
- = do (tc, tvs, parms) <- gol ty []
- mapM_ chk_pred cxt
- return (L l cxt, tc, tvs, parms)
+-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
+-- Int :*: Bool into (:*:, [Int, Bool])
+-- returning the pieces
+checkTyClHdr ty
+ = goL ty []
where
- gol (L l ty) acc = go l ty acc
+ goL (L l ty) acc = go l ty acc
go l (HsTyVar tc) acc
- | isRdrTc tc = do tvs <- extractTyVars acc
- return (L l tc, tvs, acc)
+ | isRdrTc tc = return (L l tc, acc)
+
go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
- | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
- return (ltc, tvs, t1:t2:acc)
- go _ (HsParTy ty) acc = gol ty acc
- go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
- go l _ _ =
- parseError l "Malformed head of type or class declaration"
-
- -- The predicates in a type or class decl must be class predicates or
- -- equational constraints. They need not all have variable-only
- -- arguments, even in Haskell 98.
- -- E.g. class (Monad m, Monad (t m)) => MonadT t m
- chk_pred (L _ (HsClassP _ _)) = return ()
- chk_pred (L _ (HsEqualP _ _)) = return ()
- chk_pred (L l _)
- = parseError l "Malformed context in type or class declaration"
-
--- Extract the type variables of a list of type parameters.
---
--- * Type arguments can be complex type terms (needed for associated type
--- declarations).
---
-extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-extractTyVars tvs = collects tvs []
- where
- -- Collect all variables (2nd arg serves as an accumulator)
- collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
- -> P [LHsTyVarBndr RdrName]
- collect (L l (HsForAllTy _ _ _ _)) =
- const $ parseError l "Forall type not allowed as type parameter"
- collect (L l (HsTyVar tv))
- | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
- | otherwise = return
- collect (L l (HsBangTy _ _ )) =
- const $ parseError l "Bang-style type annotations not allowed as type parameter"
- collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
- collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
- collect (L _ (HsListTy t )) = collect t
- collect (L _ (HsPArrTy t )) = collect t
- collect (L _ (HsTupleTy _ ts )) = collects ts
- collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
- collect (L _ (HsParTy t )) = collect t
- collect (L _ (HsNumTy _ )) = return
- collect (L l (HsPredTy _ )) =
- const $ parseError l "Predicate not allowed as type parameter"
- collect (L l (HsKindSig (L _ ty) k))
- | HsTyVar tv <- ty, isRdrTyVar tv
- = return . (L l (KindedTyVar tv k) :)
- | otherwise
- = const $ parseError l "Kind signature only allowed for type variables"
- collect (L l (HsSpliceTy _ )) =
- const $ parseError l "Splice not allowed as type parameter"
- collect (L _ (HsDocTy t _ )) = collect t
-
- -- Collect all variables of a list of types
- collects [] = return
- collects (t:ts) = collects ts >=> collect t
-
- (f >=> g) x = f x >>= g
+ | isRdrTc tc = return (ltc, t1:t2:acc)
+ go _ (HsParTy ty) acc = goL ty acc
+ go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
+ go l _ _ = parseError l "Malformed head of type or class declaration"
-- Check that associated type declarations of a class are all kind signatures.
--
= return (TypeSig (L l v) ty)
checkValSig (L l _) _
= parseError l "Invalid type signature"
-
-mkGadtDecl :: [Located RdrName]
- -> LHsType RdrName -- assuming HsType
- -> [ConDecl RdrName]
--- We allow C,D :: ty
--- and expand it as if it had been
--- C :: ty; D :: ty
--- (Just like type signatures in general.)
-mkGadtDecl names ty
- = [mk_gadt_con name qvars cxt tau | name <- names]
- where
- (qvars,cxt,tau) = case ty of
- L _ (HsForAllTy _ qvars cxt tau) -> (qvars, cxt, tau)
- _ -> ([], noLoc [], ty)
-
-mk_gadt_con :: Located RdrName
- -> [LHsTyVarBndr RdrName]
- -> LHsContext RdrName
- -> LHsType RdrName
- -> ConDecl RdrName
-mk_gadt_con name qvars cxt ty
- = ConDecl { con_name = name
- , con_explicit = Implicit
- , con_qvars = qvars
- , con_cxt = cxt
- , con_details = PrefixCon []
- , con_res = ResTyGADT ty
- , con_doc = Nothing }
- -- NB: we put the whole constr type into the ResTyGADT for now;
- -- the renamer will unravel it once it has sorted out
- -- operator fixities
-
--- A variable binding is parsed as a FunBind.
+\end{code}
+\begin{code}
-- The parser left-associates, so there should
-- not be any OpApps inside the e's
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
isFunLhs :: LHsExpr RdrName
-> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
+-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
--
-- The whole LHS is parsed as a single expression.
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
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,
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
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
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"),
%*********************************************************
\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)
= 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
; 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))
-> 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]
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
| 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"
module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
- rnHsSigType, rnHsTypeFVs,
+ rnHsSigType, rnHsTypeFVs, rnConDeclFields,
-- Precence related stuff
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
import HsSyn
import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn ( extractHsTyNames )
-import RnHsDoc ( rnLHsDoc )
+import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import TcRnMonad
import RdrName
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)
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}
%*********************************************************
; 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
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
; 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
; 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
-> 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
<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"
+ | otherwise = "no"
+ f (T2 a b) = show a
+</programlisting>
+Note that <literal>f</literal> is not overloaded; the <literal>Eq</literal> constraint arising
+from the use of <literal>==</literal> is discharged by the pattern match on <literal>T1</literal>
+and similarly the <literal>Show</literal> constraint arising from the use of <literal>show</literal>.
</para></listitem>
<listitem><para>
</programlisting>
or even a mixture of the two:
<programlisting>
- data Foo a :: (* -> *) -> * where ...
+ data Bar a :: (* -> *) -> * where ...
</programlisting>
The type variables (if given) may be explicitly kinded, so we could also write the header for <literal>Foo</literal>
like this:
<programlisting>
- data Foo a (b :: * -> *) where ...
+ data Bar a (b :: * -> *) where ...
</programlisting>
</para></listitem>
</para></listitem>
<listitem><para>
+The type signature may have quantified type variables that do not appear
+in the result type:
+<programlisting>
+ data Foo where
+ MkFoo :: a -> (a->Bool) -> Foo
+ Nil :: Foo
+</programlisting>
+Here the type variable <literal>a</literal> does not appear in the result type
+of either constructor.
+Although it is universally quantified in the type of the constructor, such
+a type variable is often called "existential".
+Indeed, the above declaration declares precisely the same type as
+the <literal>data Foo</literal> in <xref linkend="existential-quantification"/>.
+</para><para>
+The type may contain a class context too, of course:
+<programlisting>
+ data Showable where
+ MkShowable :: Show a => a -> Showable
+</programlisting>
+</para></listitem>
+
+<listitem><para>
You can use record syntax on a GADT-style data type declaration:
<programlisting>
data Person where
- Adult { name :: String, children :: [Person] } :: Person
- Child { name :: String } :: Person
+ Adult :: { name :: String, children :: [Person] } -> Person
+ Child :: Show a => { name :: !String, funny :: a } -> Person
</programlisting>
As usual, for every constructor that has a field <literal>f</literal>, the type of
field <literal>f</literal> must be the same (modulo alpha conversion).
-</para>
-<para>
-At the moment, record updates are not yet possible with GADT-style declarations,
-so support is limited to record construction, selection and pattern matching.
-For example
-<programlisting>
- aPerson = Adult { name = "Fred", children = [] }
+The <literal>Child</literal> constructor above shows that the signature
+may have a context, existentially-quantified variables, and strictness annotations,
+just as in the non-record case. (NB: the "type" that follows the double-colon
+is not really a type, because of the record syntax and strictness annotations.
+A "type" of this form can appear only in a constructor signature.)
+</para></listitem>
- shortName :: Person -> Bool
- hasChildren (Adult { children = kids }) = not (null kids)
- hasChildren (Child {}) = False
-</programlisting>
+<listitem><para>
+Record updates are allowed with GADT-style declarations,
+only fields that have the following property: the type of the field
+mentions no existential type variables.
</para></listitem>
<listitem><para>
projects / ghc-hetmet.git / commitdiff