Commit 408439c0 authored by simonpj's avatar simonpj
Browse files

[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.
parent 0b78478f
......@@ -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
......
......@@ -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}
......
......@@ -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)
......
{- -*-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 }
......@@ -727,6 +746,18 @@ varids0 :: { [RdrName] }
: {- empty -} { [] }
| varids0 tyvar { $2 : $1 }
-----------------------------------------------------------------------------
-- Kinds
kind :: { Kind }
: akind { $1 }
| akind '->' kind { mkArrowKind $1 $3 }
akind :: { Kind }
: '*' { liftedTypeKind }
| '(' kind ')' { $2 }
-----------------------------------------------------------------------------
-- Datatype declarations
......@@ -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 }
......
......@@ -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) $
......
......@@ -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
......
......@@ -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`
......
......@@ -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')
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment