From 589ba227fff5946de91cf3a9b88c80953d95f9c7 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 15 Sep 2006 20:51:54 +0000 Subject: [PATCH] Cleanup (re type function parsing) Mon Jul 31 17:20:56 EDT 2006 Manuel M T Chakravarty * Cleanup (re type function parsing) --- compiler/hsSyn/HsDecls.lhs | 26 ++++++++++++++++++++++++-- compiler/parser/Parser.y.pp | 28 +++++++++++++++++----------- compiler/parser/RdrHsSyn.lhs | 12 ++++++------ 3 files changed, 47 insertions(+), 19 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index f2bf9d3..059fe4d 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -329,6 +329,24 @@ Interface file code: -- for a module. That's why (despite the misnomer) IfaceSig and ForeignType -- are both in TyClDecl +-- Representation of type functions and associated data types & synonyms +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- 'TyData' and 'TySynonym' have a field 'tcdPats::Maybe [LHsType name]', with +-- the following meaning: +-- +-- * If it is 'Nothing', we have a *vanilla* data type declaration or type +-- synonym declaration and 'tcdVars' contains the type parameters of the +-- type constructor. +-- +-- * If it is 'Just pats', we have the definition of an associated data type +-- or a type function equations (toplevel or nested in an instance +-- declarations). Then, 'pats' are type patterns for the type-indexes of +-- the type constructor and 'tcdVars' are the variables in those +-- patterns. Hence, the arity of the type constructor is 'length tcdPats' +-- and *not* 'length tcdVars'. +-- +-- In both cases, 'tcdVars' collects all variables we need to quantify over. + type LTyClDecl name = Located (TyClDecl name) data TyClDecl name @@ -368,6 +386,8 @@ data TyClDecl name | TySynonym { tcdLName :: Located name, -- type constructor tcdTyVars :: [LHsTyVarBndr name], -- type variables tcdTyPats :: Maybe [LHsType name], -- Type patterns + -- 'Nothing' => vanilla + -- type synonym tcdSynRhs :: LHsType name -- synonym expansion } @@ -378,7 +398,8 @@ data TyClDecl name tcdSigs :: [LSig name], -- Methods' signatures tcdMeths :: LHsBinds name, -- Default methods tcdATs :: [LTyClDecl name] -- Associated types; ie - -- only 'TyData' + -- only 'TyData', + -- 'TyFunction', -- and 'TySynonym' } @@ -653,7 +674,8 @@ data InstDecl name -- figures out the quantified type variables for us. (LHsBinds name) [LSig name] -- User-supplied pragmatic info - [LTyClDecl name]-- Associated types + [LTyClDecl name]-- Associated types (ie, 'TyData' and + -- 'TySynonym' only) instance (OutputableBndr name) => Outputable (InstDecl name) where diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 7b9786f..158043b 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -467,7 +467,7 @@ cl_decl :: { LTyClDecl RdrName } : 'class' tycl_hdr fds where {% do { let { (binds, sigs, ats) = cvBindsAndSigs (unLoc $4) - ; (ctxt, tc, tvs, Just tparms) = unLoc $2} + ; (ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms False -- only type vars allowed ; return $ L (comb4 $1 $2 $3 $4) (mkClassDecl (ctxt, tc, tvs) @@ -505,19 +505,25 @@ ty_decl :: { LTyClDecl RdrName } -- data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving - { L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr - -- in case constrs and deriving are - -- both empty - (mkTyData (unLoc $1) (unLoc $2) Nothing - (reverse (unLoc $3)) (unLoc $4)) } + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + ; tpats <- checkTyVars tparms True -- 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, tpats) + Nothing (reverse (unLoc $3)) (unLoc $4)) } } -- GADT declaration | data_or_newtype tycl_hdr opt_kind_sig 'where' gadt_constrlist deriving - { L (comb4 $1 $2 $4 $5) - (mkTyData (unLoc $1) (unLoc $2) $3 - (reverse (unLoc $5)) (unLoc $6)) } + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + ; tpats <- checkTyVars tparms True -- can have type pats + ; return $ + L (comb4 $1 $2 $4 $5) + (mkTyData (unLoc $1) (ctxt, tc, tvs, tpats) $3 + (reverse (unLoc $5)) (unLoc $6)) } } opt_iso :: { Bool } : { False } @@ -540,7 +546,7 @@ opt_kind_sig :: { Maybe Kind } : { Nothing } | '::' kind { Just (unLoc $2) } --- tycl_hdr parses the header of a type decl, +-- tycl_hdr parses the header of a class or data type decl, -- which takes the form -- T a b -- Eq a => T a @@ -550,7 +556,7 @@ opt_kind_sig :: { Maybe Kind } tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], - Maybe [LHsType RdrName]) } + [LHsType RdrName]) } : context '=>' type {% checkTyClHdr $1 $3 >>= return.LL } | type {% checkTyClHdr (noLoc []) $1 >>= return.L1 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index b0cf2cf..1867ce6 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -35,7 +35,7 @@ module RdrHsSyn ( checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPred, -- HsType -> P HsPred - checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) + checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName]) checkTyVars, -- [LHsType RdrName] -> Bool -> P () checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl RdrName) @@ -401,7 +401,8 @@ checkTyVars tparms nonVarsOk = -- Check whether the type arguments in a type synonym head are simply -- variables. If not, we have a type equation of a type function and return --- all patterns. +-- all patterns. If yes, we return 'Nothing' as the third component to +-- indicate a vanilla type synonym. -- checkSynHdr :: LHsType RdrName -> Bool -- non-variables admitted? @@ -409,7 +410,7 @@ checkSynHdr :: LHsType RdrName [LHsTyVarBndr RdrName], -- parameters Maybe [LHsType RdrName]) -- type patterns checkSynHdr ty nonVarsOk = - do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty + do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty ; typats <- checkTyVars tparms nonVarsOk ; return (tc, tvs, typats) } @@ -420,8 +421,7 @@ 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 - Maybe [LHsType RdrName]) -- parameters of head symbol; wrapped into - -- 'Maybe' for 'mkTyData' + [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 @@ -437,7 +437,7 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName checkTyClHdr (L l cxt) ty = do (tc, tvs, parms) <- gol ty [] mapM_ chk_pred cxt - return (L l cxt, tc, tvs, Just parms) + return (L l cxt, tc, tvs, parms) where gol (L l ty) acc = go l ty acc -- 1.7.10.4