From 432b9c9322181a3644083e3c19b7e240d90659e7 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 2 Jul 2009 09:46:57 +0000 Subject: [PATCH 1/1] 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. --- compiler/deSugar/DsMeta.hs | 8 +- compiler/hsSyn/Convert.lhs | 49 +++-- compiler/hsSyn/HsDecls.lhs | 49 +++-- compiler/hsSyn/HsTypes.lhs | 23 +- compiler/parser/HaddockUtils.hs | 11 +- compiler/parser/Parser.y.pp | 217 ++++++------------- compiler/parser/ParserCore.y | 35 ++-- compiler/parser/RdrHsSyn.lhs | 395 ++++++++++++++++++----------------- compiler/rename/RnHsSyn.lhs | 1 + compiler/rename/RnSource.lhs | 123 +++++------ compiler/rename/RnTypes.lhs | 24 ++- compiler/typecheck/TcHsType.lhs | 16 +- compiler/typecheck/TcTyClsDecls.lhs | 9 +- docs/users_guide/glasgow_exts.xml | 79 +++++-- 14 files changed, 529 insertions(+), 510 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2de2cae..3518aaf 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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'] diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 31a0bca..9bae01e 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -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) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 83bd6d5..c770386 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -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} %************************************************************************ diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 7d91a42..d5b674b 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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) diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs index 70a5da2..ea73911 100644 --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -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 [] _ = [] diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index ef48bb4..cbc3bcb 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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] } } constrs :: { Located [LConDecl RdrName] } : {- empty; a GHC extension -} { noLoc [] } @@ -1192,10 +1110,12 @@ constrs1 :: { Located [LConDecl RdrName] } 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 } @@ -1209,21 +1129,22 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } -- 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). diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index bf95946..0f2bb97 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -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 -} { [] } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index bd8299b..779b67b 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -8,10 +8,11 @@ module RdrHsSyn ( 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, @@ -29,16 +30,15 @@ module RdrHsSyn ( -- -> 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) @@ -76,7 +76,6 @@ import Outputable import FastString import List ( isSuffixOf, nubBy ) -import Monad ( unless ) #include "HsVersions.h" \end{code} @@ -95,6 +94,9 @@ It's used when making the for-alls explicit. 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 @@ -105,19 +107,23 @@ extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrN 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)) @@ -167,35 +173,57 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** 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} %************************************************************************ @@ -376,29 +404,88 @@ add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" \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 @@ -411,7 +498,26 @@ 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 @@ -436,128 +542,69 @@ checkDictTy (L spn ty) = check ty [] 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. -- @@ -812,41 +859,10 @@ checkValSig (L l (HsVar v)) ty = 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]) @@ -861,6 +877,7 @@ splitBang _ = Nothing 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. diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index eb0e2e2..7d78536 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -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 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 5a071ee..3c9f77f 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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" diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 61731e8..3086b94 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -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} %********************************************************* diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index c8c0efc..a63c2ce 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f0619d8..633dc52 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -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 diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index e8e721c..5d1b5cf 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -2364,14 +2364,34 @@ In this example we give a single signature for T1 and 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 "data T a where" header +have no scope, and different constructors may have different universally-quantified type variables: + + 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 + + + + +A constructor signature may mention type class constraints, which can differ for +different constructors. For example, this is fine: 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 +When patten matching, these constraints are made available to discharge constraints +in the body of the match. For example: + + f :: T a -> String + f (T1 x y) | x==y = "yes" + | otherwise = "no" + f (T2 a b) = show a + +Note that f is not overloaded; the Eq constraint arising +from the use of == is discharged by the pattern match on T1 +and similarly the Show constraint arising from the use of show. @@ -2383,12 +2403,12 @@ have no scope. Indeed, one can write a kind signature instead: or even a mixture of the two: - data Foo a :: (* -> *) -> * where ... + data Bar a :: (* -> *) -> * where ... The type variables (if given) may be explicitly kinded, so we could also write the header for Foo like this: - data Foo a (b :: * -> *) where ... + data Bar a (b :: * -> *) where ... @@ -2419,27 +2439,48 @@ declaration. For example, these two declarations are equivalent +The type signature may have quantified type variables that do not appear +in the result type: + + data Foo where + MkFoo :: a -> (a->Bool) -> Foo + Nil :: Foo + +Here the type variable a 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 data Foo in . + +The type may contain a class context too, of course: + + data Showable where + MkShowable :: Show a => a -> Showable + + + + You can use record syntax on a GADT-style data type declaration: 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 As usual, for every constructor that has a field f, the type of field f must be the same (modulo alpha conversion). - - -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 - - aPerson = Adult { name = "Fred", children = [] } +The Child 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.) + - shortName :: Person -> Bool - hasChildren (Adult { children = kids }) = not (null kids) - hasChildren (Child {}) = False - + +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. -- 1.7.10.4