Commit 77ede632 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Revised kind signatures

Tue Aug  1 14:10:39 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Revised kind signatures
parent 589ba227
......@@ -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 <+>
......
......@@ -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)
......
......@@ -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)
......
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