From 77ede632bfb1f0df2224b392cd0b7ed009baa9d0 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 15 Sep 2006 20:54:39 +0000 Subject: [PATCH] Revised kind signatures Tue Aug 1 14:10:39 EDT 2006 Manuel M T Chakravarty * Revised kind signatures --- compiler/hsSyn/HsDecls.lhs | 13 ++++++------- compiler/parser/Parser.y.pp | 28 ++++++++++++++++++++-------- compiler/parser/RdrHsSyn.lhs | 23 ++++++++++++++--------- 3 files changed, 40 insertions(+), 24 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 059fe4d..90479ab 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -362,7 +362,9 @@ data TyClDecl name tcdTyVars :: [LHsTyVarBndr name], -- Type variables tcdTyPats :: Maybe [LHsType name], -- Type patterns tcdKindSig:: Maybe Kind, -- Optional kind sig; - -- (only for the 'where' form) + -- (only for the + -- 'where' form and + -- indexed type sigs) tcdCons :: [LConDecl name], -- Data constructors -- For data T a = T1 | T2 a the LConDecls all have ResTyH98 @@ -380,7 +382,7 @@ data TyClDecl name | TyFunction {tcdLName :: Located name, -- type constructor tcdTyVars :: [LHsTyVarBndr name], -- type variables tcdIso :: Bool, -- injective type? - tcdKindSig:: Maybe Kind -- result kind + tcdKind :: Kind -- result kind } | TySynonym { tcdLName :: Located name, -- type constructor @@ -493,17 +495,14 @@ instance OutputableBndr name = hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon] ppr (TyFunction {tcdLName = ltycon, tcdTyVars = tyvars, tcdIso = iso, - tcdKindSig = mb_sig}) + tcdKind = kind}) = typeMaybeIso <+> pp_decl_head [] ltycon tyvars Nothing <+> - ppr_sig mb_sig + dcolon <+> pprKind kind where typeMaybeIso = if iso then ptext SLIT("type iso") else ptext SLIT("type") - ppr_sig Nothing = empty - ppr_sig (Just kind) = dcolon <+> pprKind kind - ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats, tcdSynRhs = mono_ty}) = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars typats <+> diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 158043b..3951128 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -444,7 +444,8 @@ topdecls :: { OrdList (LHsDecl RdrName) } topdecl :: { OrdList (LHsDecl RdrName) } : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } - | ty_decl {% checkTopTyClD $1 >>= return.unitOL.L1 } + | ty_decl {% checkTopTypeD $1 >>= + return.unitOL.L1 } | 'instance' inst_type where { let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3) in unitOL (L (comb3 $1 $2 $3) @@ -478,7 +479,7 @@ cl_decl :: { LTyClDecl RdrName } ty_decl :: { LTyClDecl RdrName } -- type function signature and equations (w/ type synonyms as special -- case); we need to handle all this in one rule to avoid a large - -- number of shift/reduce conflicts (due to the generality of `type') + -- number of shift/reduce conflicts : 'type' opt_iso type kind_or_ctype -- -- Note the use of type for the head; this allows @@ -497,16 +498,28 @@ ty_decl :: { LTyClDecl RdrName } ; return (L (comb3 $1 $3 kind) (TyFunction tc tvs $2 (unLoc kind))) } - Right ty -> + Right ty | not $2 -> do { (tc, tvs, typats) <- checkSynHdr $3 True ; return (L (comb2 $1 ty) (TySynonym tc tvs typats ty)) } + Right ty | otherwise -> + parseError (comb2 $1 ty) + "iso tag is only allowed in kind signatures" } + -- kind signature of indexed type + | data_or_newtype tycl_hdr '::' kind + {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} + ; checkTyVars tparms False -- no type pattern + ; return $ + L (comb3 $1 $2 $4) + (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) + (Just (unLoc $4)) [] Nothing) } } + -- data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2} - ; tpats <- checkTyVars tparms True -- can have type pats + ; tpats <- checkTyVars tparms True -- can have type pats ; return $ L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr in case @@ -529,10 +542,9 @@ opt_iso :: { Bool } : { False } | 'iso' { True } -kind_or_ctype :: { Either (Located (Maybe Kind)) (LHsType RdrName) } - : { Left (noLoc Nothing) } - | '::' kind { Left (LL (Just (unLoc $2))) } - | '=' ctype { Right (LL (unLoc $2)) } +kind_or_ctype :: { Either (Located Kind) (LHsType RdrName) } + : '::' kind { Left (LL (unLoc $2)) } + | '=' ctype { Right (LL (unLoc $2)) } -- Note ctype, not sigtype, on the right of '=' -- We allow an explicit for-all but we don't insert one -- in type Foo a = (b,b) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 1867ce6..980c7f7 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -38,7 +38,7 @@ module RdrHsSyn ( 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) + checkTopTypeD, -- LTyClDecl RdrName -> P (HsDecl RdrName) checkInstType, -- HsType -> P HsType checkPattern, -- HsExp -> P HsPat checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] @@ -433,7 +433,7 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName -- result. Eg, for -- T Int [a] -- we return --- ('()', 'T', ['a'], Just ['Int', '[a]']) +-- ('()', 'T', ['a'], ['Int', '[a]']) checkTyClHdr (L l cxt) ty = do (tc, tvs, parms) <- gol ty [] mapM_ chk_pred cxt @@ -506,16 +506,21 @@ extractTyVars tvs = collects [] tvs tvs' <- collects tvs ts collect tvs' t --- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring --- that all type parameters are variables only (which is in contrast to --- associated type declarations). +-- Wrap a toplevel type or data declaration into 'TyClD' and ensure for +-- data declarations that all type parameters are variables only (which is in +-- contrast to type functions and associated type declarations). -- -checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName) -checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = +checkTopTypeD :: LTyClDecl RdrName -> P (HsDecl RdrName) +checkTopTypeD (L _ d@TyData {tcdTyPats = Just typats}) = do + -- `tcdTyPats' will only be of the form `Just typats' if `typats' contains + -- a non-variable pattern. We call `checkTyPats' instead of raising an + -- error straight away, as `checkTyPats' raises the error at the location + -- of that non-variable pattern. + -- checkTyVars typats False - return $ TyClD d {tcdTyPats = Nothing} -checkTopTyClD (L _ d) = return $ TyClD d + panic "checkTopTypeD: check on previous line should fail w/ a parse error" +checkTopTypeD (L _ d) = return $ TyClD d checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l t) -- 1.7.10.4