From 408439c03f074ed86b0bbe534c7210efb271b543 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 11 Feb 2002 15:16:27 +0000 Subject: [PATCH] [project @ 2002-02-11 15:16:25 by simonpj] ---------------------------------- Implement kinded type declarations ---------------------------------- This commit allows the programmer to supply kinds in * data decls * type decls * class decls * 'forall's in types e.g. data T (x :: *->*) = MkT type Composer c = forall (x :: * -> *) (y :: * -> *) (z :: * -> *). (c y z) -> (c x y) -> (c x z); This is occasionally useful. It turned out to be convenient to add the form (type :: kind) to the syntax of types too, so you can put kind signatures in types as well. --- ghc/compiler/hsSyn/HsTypes.lhs | 9 ++- ghc/compiler/parser/Lex.lhs | 2 + ghc/compiler/parser/ParseUtil.lhs | 14 +++-- ghc/compiler/parser/Parser.y | 102 ++++++++++++++++++++++----------- ghc/compiler/parser/RdrHsSyn.lhs | 6 +- ghc/compiler/rename/ParseIface.y | 6 +- ghc/compiler/rename/RnHsSyn.lhs | 1 + ghc/compiler/rename/RnTypes.lhs | 4 ++ ghc/compiler/typecheck/TcMonoType.lhs | 8 +++ 9 files changed, 105 insertions(+), 47 deletions(-) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index acdf8fd..3c42629 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -41,7 +41,7 @@ import Name ( Name, getName ) import OccName ( NameSpace, tvName ) import Var ( TyVar, tyVarKind ) import Subst ( substTyWith ) -import PprType ( {- instance Outputable Kind -}, pprParendKind ) +import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind ) import BasicTypes ( Boxity(..), Arity, IPName, tupleParens ) import PrelNames ( mkTupConRdrName, listTyConKey, parrTyConKey, usOnceTyConKey, usManyTyConKey, hasKey, @@ -109,6 +109,9 @@ data HsType name -- these next two are only used in interfaces | HsPredTy (HsPred name) + | HsKindSig (HsType name) -- (ty :: kind) + Kind -- A type with a kind signature + ----------------------- hsUsOnce, hsUsMany :: HsType RdrName @@ -276,6 +279,7 @@ ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) (sep [p1, (<>) (ptext SLIT("-> ")) p2]) ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys) +ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_ty pREC_TOP ty <+> dcolon <+> pprKind kind) ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty) where @@ -455,6 +459,9 @@ eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2) eq_hsType env (HsListTy ty1) (HsListTy ty2) = eq_hsType env ty1 ty2 +eq_hsType env (HsKindSig ty1 k1) (HsKindSig ty2 k2) + = eq_hsType env ty1 ty2 && k1 `eqKind` k2 + eq_hsType env (HsPArrTy ty1) (HsPArrTy ty2) = eq_hsType env ty1 ty2 diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 06fe82f..01fcc3b 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -183,6 +183,7 @@ data Token | ITdarrow | ITminus | ITbang + | ITstar | ITdot | ITbiglam -- GHC-extension symbols @@ -381,6 +382,7 @@ haskellKeySymsFM = listToUFM $ ,("=>", ITdarrow) ,("-", ITminus) ,("!", ITbang) + ,("*", ITstar) ,(".", ITdot) -- sadly, for 'forall a . t' ] \end{code} diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 2ee9664..ca546b8 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -113,11 +113,12 @@ checkInstType t ty -> checkDictTy ty [] `thenP` \ dict_ty-> returnP (HsForAllTy Nothing [] dict_ty) -checkTyVars :: [RdrNameHsTyVar] -> P [RdrNameHsType] +checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar] checkTyVars tvs = mapP chk tvs where - chk (UserTyVar tv) = returnP (HsTyVar tv) - chk other = parseError "Illegal kinded type variable" + chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k) + chk (HsTyVar tv) = returnP (UserTyVar tv) + chk other = parseError "Type found where type variable expected" checkContext :: RdrNameHsType -> P RdrNameContext checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type @@ -131,9 +132,12 @@ checkContext t returnP [p] checkPred :: RdrNameHsType -> P (HsPred RdrName) +-- Watch out.. in ...deriving( Show )... we use checkPred on +-- the list of partially applied predicates in the deriving, +-- so there can be zero args. checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty) -checkPred (HsAppTy l r) - = go l [r] +checkPred ty + = go ty [] where go (HsTyVar t) args | not (isRdrTyVar t) = returnP (HsClassP t args) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index c9e2042..e98b1ff 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.85 2002/02/11 09:27:22 simonpj Exp $ +$Id: Parser.y,v 1.86 2002/02/11 15:16:26 simonpj Exp $ Haskell grammar. @@ -28,6 +28,7 @@ import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module import CmdLineOpts ( opt_SccProfilingOn ) +import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), NewOrData(..), StrictnessMark(..), Activation(..) ) import Panic @@ -45,10 +46,14 @@ import Outputable ----------------------------------------------------------------------------- Conflicts: 21 shift/reduce, -=chak[4Feb2] -8 for abiguity in 'if x then y else z + 1' +9 for abiguity in 'if x then y else z + 1' (shift parses as 'if x then y else (z + 1)', as per longest-parse rule) + 8 because op might be: - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM 1 for ambiguity in 'if x then y else z :: T' (shift parses as 'if x then y else (z :: T)', as per longest-parse rule) +1 for ambiguity in 'if x then y else z with ?x=3' + (shift parses as 'if x then y else (z with ?x=3)' + 3 for ambiguity in 'case x of y :: a -> b' (don't know whether to reduce 'a' as a btype or shift the '->'. conclusion: bogus expression anyway, doesn't matter) @@ -166,6 +171,7 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2] '=>' { ITdarrow } '-' { ITminus } '!' { ITbang } + '*' { ITstar } '.' { ITdot } '{' { ITocurly } -- special symbols @@ -341,12 +347,13 @@ topdecls :: { [RdrBinding] } | topdecl { [$1] } topdecl :: { RdrBinding } - : srcloc 'type' simpletype '=' ctype + : srcloc 'type' tycon tv_bndrs '=' ctype -- Note ctype, not sigtype. -- We allow an explicit for-all but we don't insert one -- in type Foo a = (b,b) -- Instead we just say b is out of scope - { RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) } + { RdrHsDecl (TyClD (TySynonym $3 $4 $6 $1)) } + | srcloc 'data' tycl_hdr constrs deriving {% returnP (RdrHsDecl (TyClD @@ -369,7 +376,7 @@ topdecl :: { RdrBinding } (groupBindings $4) in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) } - | srcloc 'default' '(' types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) } + | srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) } | 'foreign' fdecl { RdrHsDecl $2 } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } @@ -382,13 +389,15 @@ topdecl :: { RdrBinding } -- (Eq a, Ord b) => T a b -- Rather a lot of inlining here, else we get reduce/reduce errors tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) } - : '(' types ')' '=>' tycon tyvars {% mapP checkPred $2 `thenP` \ cxt -> - returnP (cxt, $5, $6) } - | tycon tyvars '=>' tycon tyvars {% checkTyVars $2 `thenP` \ args -> - returnP ([HsClassP $1 args], $4, $5) } - | qtycon tyvars '=>' tycon tyvars {% checkTyVars $2 `thenP` \ args -> - returnP ([HsClassP $1 args], $4, $5) } - | tycon tyvars { ([], $1, $2) } + : '(' comma_types1 ')' '=>' tycon tv_bndrs {% mapP checkPred $2 `thenP` \ cxt -> + returnP (cxt, $5, $6) } + | qtycon atypes1 '=>' tycon atypes0 {% checkTyVars $5 `thenP` \ tvs -> + returnP ([HsClassP $1 $2], $4, tvs) } + | qtycon atypes0 {% checkTyVars $2 `thenP` \ tvs -> + returnP ([], $1, tvs) } + -- We have to have qtycon in this production to avoid s/r conflicts + -- with the previous one. The renamer will complain if we use + -- a qualified tycon. decls :: { [RdrBinding] } : decls ';' decl { $3 : $1 } @@ -642,7 +651,7 @@ sigtypes :: { [RdrNameHsType] } | sigtypes ',' sigtype { $3 : $1 } sigtype :: { RdrNameHsType } - : ctype { (mkHsForAllTy Nothing [] $1) } + : ctype { mkHsForAllTy Nothing [] $1 } sig_vars :: { [RdrName] } : sig_vars ',' var { $3 : $1 } @@ -653,7 +662,7 @@ sig_vars :: { [RdrName] } -- A ctype is a for-all type ctype :: { RdrNameHsType } - : 'forall' tyvars '.' ctype { mkHsForAllTy (Just $2) [] $4 } + : 'forall' tv_bndrs '.' ctype { mkHsForAllTy (Just $2) [] $4 } | context '=>' type { mkHsForAllTy Nothing $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy | type { $1 } @@ -676,17 +685,18 @@ gentype :: { RdrNameHsType } | atype tyconop atype { HsOpTy $1 $2 $3 } btype :: { RdrNameHsType } - : btype atype { (HsAppTy $1 $2) } + : btype atype { HsAppTy $1 $2 } | atype { $1 } atype :: { RdrNameHsType } : gtycon { HsTyVar $1 } | tyvar { HsTyVar $1 } - | '(' type ',' types ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2 : reverse $4) } - | '(#' types '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) (reverse $2) } + | '(' type ',' comma_types1 ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2:$4) } + | '(#' comma_types1 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } | '[' type ']' { HsListTy $2 } | '[:' type ':]' { HsPArrTy $2 } | '(' ctype ')' { $2 } + | '(' ctype '::' kind ')' { HsKindSig $2 $4 } -- Generics | INTEGER { HsNumTy $1 } @@ -697,21 +707,30 @@ atype :: { RdrNameHsType } inst_type :: { RdrNameHsType } : ctype {% checkInstType $1 } -types0 :: { [RdrNameHsType] } - : types { reverse $1 } +comma_types0 :: { [RdrNameHsType] } + : comma_types1 { $1 } | {- empty -} { [] } -types :: { [RdrNameHsType] } +comma_types1 :: { [RdrNameHsType] } : type { [$1] } - | types ',' type { $3 : $1 } - -simpletype :: { (RdrName, [RdrNameHsTyVar]) } - : tycon tyvars { ($1, reverse $2) } + | type ',' comma_types1 { $1 : $3 } -tyvars :: { [RdrNameHsTyVar] } - : tyvar tyvars { UserTyVar $1 : $2 } +atypes0 :: { [RdrNameHsType] } + : atypes1 { $1 } | {- empty -} { [] } +atypes1 :: { [RdrNameHsType] } + : atype { [$1] } + | atype atypes1 { $1 : $2 } + +tv_bndrs :: { [RdrNameHsTyVar] } + : tv_bndr tv_bndrs { $1 : $2 } + | {- empty -} { [] } + +tv_bndr :: { RdrNameHsTyVar } + : tyvar { UserTyVar $1 } + | '(' tyvar '::' kind ')' { IfaceTyVar $2 $4 } + fds :: { [([RdrName], [RdrName])] } : {- empty -} { [] } | '|' fds1 { reverse $2 } @@ -728,6 +747,18 @@ varids0 :: { [RdrName] } | varids0 tyvar { $2 : $1 } ----------------------------------------------------------------------------- +-- Kinds + +kind :: { Kind } + : akind { $1 } + | akind '->' kind { mkArrowKind $1 $3 } + +akind :: { Kind } + : '*' { liftedTypeKind } + | '(' kind ')' { $2 } + + +----------------------------------------------------------------------------- -- Datatype declarations newconstr :: { RdrNameConDecl } @@ -750,7 +781,7 @@ constr :: { RdrNameConDecl } { mkConDecl (fst $3) $2 [] (snd $3) $1 } forall :: { [RdrNameHsTyVar] } - : 'forall' tyvars '.' { $2 } + : 'forall' tv_bndrs '.' { $2 } | {- empty -} { [] } constr_stuff :: { (RdrName, RdrNameConDetails) } @@ -878,7 +909,7 @@ fexp :: { RdrNameHsExpr } | aexp { $1 } aexps0 :: { [RdrNameHsExpr] } - : aexps { (reverse $1) } + : aexps { reverse $1 } aexps :: { [RdrNameHsExpr] } : aexps aexp { $2 : $1 } @@ -1006,7 +1037,7 @@ alt :: { RdrNameMatch } ralt :: { [RdrNameGRHS] } : '->' srcloc exp { [GRHS [ResultStmt $3 $2] $2] } - | gdpats { (reverse $1) } + | gdpats { reverse $1 } gdpats :: { [RdrNameGRHS] } : gdpats gdpat { $2 : $1 } @@ -1093,9 +1124,7 @@ deprec_var : var { $1 } | tycon { $1 } gtycon :: { RdrName } - : tycon { $1 } - | qtycon { $1 } - | '(' tyconop ')' { $2 } + : qtycon { $1 } | '(' qtyconop ')' { $2 } | '(' ')' { unitTyCon_RDR } | '(' '->' ')' { funTyCon_RDR } @@ -1103,7 +1132,7 @@ gtycon :: { RdrName } | '[:' ':]' { parrTyCon_RDR } | '(' commas ')' { tupleTyCon_RDR $2 } -gcon :: { RdrName } +gcon :: { RdrName } -- Data constructor namespace : '(' ')' { unitCon_RDR } | '[' ']' { nilCon_RDR } | '(' commas ')' { tupleCon_RDR $2 } @@ -1247,6 +1276,7 @@ varsym_no_minus :: { RdrName } -- varsym not including '-' special_sym :: { UserFS } special_sym : '!' { SLIT("!") } | '.' { SLIT(".") } + | '*' { SLIT("*") } ----------------------------------------------------------------------------- -- Literals @@ -1290,11 +1320,13 @@ tycon :: { RdrName } tyconop :: { RdrName } : CONSYM { mkUnqual tcClsName $1 } -qtycon :: { RdrName } -- Just the qualified kind +qtycon :: { RdrName } -- Qualified or unqualified : QCONID { mkQual tcClsName $1 } + | tycon { $1 } -qtyconop :: { RdrName } -- Just the qualified kind +qtyconop :: { RdrName } -- Qualified or unqualified : QCONSYM { mkQual tcClsName $1 } + | tyconop { $1 } commas :: { Int } : commas ',' { $1 + 1 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index c9bf3ad..c482844 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -148,11 +148,11 @@ extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsPredTy p) acc = extract_pred p acc extract_ty (HsTyVar tv) acc = tv : acc -extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc) +extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc) -- Generics -extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsNumTy num) acc = acc --- Generics +extract_ty (HsKindSig ty k) acc = extract_ty ty acc extract_ty (HsForAllTy (Just tvs) ctxt ty) acc = acc ++ (filter (`notElem` locals) $ diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 0ec54bc..ce9526c 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -144,6 +144,7 @@ import FastString ( tailFS ) '=>' { ITdarrow } '-' { ITminus } '!' { ITbang } + '*' { ITstar } '{' { ITocurly } -- special symbols '}' { ITccurly } @@ -682,9 +683,8 @@ kind :: { Kind } | akind '->' kind { mkArrowKind $1 $3 } akind :: { Kind } - : VARSYM { if $1 == SLIT("*") then - liftedTypeKind - else if $1 == SLIT("?") then + : '*' { liftedTypeKind } + | VARSYM { if $1 == SLIT("?") then openTypeKind else if $1 == SLIT("\36") then usageTypeKind -- dollar diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 539a81e..43364ae 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -84,6 +84,7 @@ extractHsTyNames ty unitNameSet tycon get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv + get (HsKindSig ty k) = get ty get (HsForAllTy (Just tvs) ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) `minusNameSet` diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 2d544f5..4ef0582 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -115,6 +115,10 @@ rnHsType doc (HsListTy ty) = rnHsType doc ty `thenRn` \ ty' -> returnRn (HsListTy ty') +rnHsType doc (HsKindSig ty k) + = rnHsType doc ty `thenRn` \ ty' -> + returnRn (HsKindSig ty' k) + rnHsType doc (HsPArrTy ty) = rnHsType doc ty `thenRn` \ ty' -> returnRn (HsPArrTy ty') diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 1d33e94..3a03d97 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -263,6 +263,11 @@ kcHsLiftedSigType = kcLiftedType kcHsType :: RenamedHsType -> TcM TcKind kcHsType (HsTyVar name) = kcTyVar name +kcHsType (HsKindSig ty k) + = kcHsType ty `thenTc` \ k' -> + unifyKind k k' `thenTc_` + returnTc k + kcHsType (HsListTy ty) = kcLiftedType ty `thenTc` \ tau_ty -> returnTc liftedTypeKind @@ -400,6 +405,9 @@ tc_type :: RenamedHsType -> TcM Type tc_type ty@(HsTyVar name) = tc_app ty [] +tc_type (HsKindSig ty k) + = tc_type ty -- Kind checking done already + tc_type (HsListTy ty) = tc_type ty `thenTc` \ tau_ty -> returnTc (mkListTy tau_ty) -- 1.7.10.4