Commit 1bade0c9 authored by simonpj's avatar simonpj
Browse files

[project @ 2003-10-21 12:54:17 by simonpj]

1. A tiresome change to HsType, to keep a record of whether or not
   the HsForAll was originally explicitly-quantified.  This is
   solely so that the type checker can print out messages that
   show the source code the programmer wrote.  Tiresome but
   easy.

2. Improve reporting of kind errors.
parent 9694f168
......@@ -19,7 +19,7 @@ import HsSyn as Hs
HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
Pat(..), HsConDetails(..), HsOverLit, BangType(..),
placeHolderType, HsType(..),
placeHolderType, HsType(..), HsExplicitForAll(..),
HsTyVarBndr(..), HsContext,
mkSimpleMatch, mkHsForAllTy
)
......@@ -98,9 +98,7 @@ cvt_top (InstanceD tys ty decs)
= Left $ InstD (InstDecl inst_ty binds sigs loc0)
where
(binds, sigs) = cvtBindsAndSigs decs
inst_ty = HsForAllTy Nothing
(cvt_context tys)
(HsPredTy (cvt_pred ty))
inst_ty = mkImplicitHsForAllTy (cvt_context tys) (HsPredTy (cvt_pred ty))
cvt_top (Meta.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0)
......@@ -321,9 +319,8 @@ cvtType ty = trans (root ty [])
trans (VarT nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args
trans (ConT tc, args) = foldl HsAppTy (HsTyVar (tconName tc)) args
trans (ForallT tvs cxt ty, []) = mkHsForAllTy (Just (cvt_tvs tvs))
(cvt_context cxt)
(cvtType ty)
trans (ForallT tvs cxt ty, []) = mkExplicitHsForAllTy
(cvt_tvs tvs) (cvt_context cxt) (cvtType ty)
split_ty_app :: Meta.Type -> (Meta.Type, [Meta.Type])
split_ty_app ty = go ty []
......
......@@ -476,7 +476,7 @@ unbangedType ty = BangType HsNoBang ty
\begin{code}
instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr (ConDecl con tvs cxt con_details loc)
= sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
= sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details]
ppr_con_details con (InfixCon ty1 ty2)
= hsep [ppr ty1, ppr con, ppr ty2]
......
......@@ -5,10 +5,10 @@
\begin{code}
module HsTypes (
HsType(..), HsTyVarBndr(..),
HsType(..), HsTyVarBndr(..), HsExplicitForAll(..),
, HsContext, HsPred(..)
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName
, splitHsInstDeclTy
......@@ -32,6 +32,7 @@ import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind )
import BasicTypes ( IPName, Boxity, tupleParens )
import PrelNames ( unboundKey )
import SrcLoc ( noSrcLoc )
import CmdLineOpts ( opt_PprStyle_Debug )
import Outputable
\end{code}
......@@ -80,7 +81,11 @@ data HsPred name = HsClassP name [HsType name]
| HsIParam (IPName name) (HsType name)
data HsType name
= HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures
= HsForAllTy HsExplicitForAll -- Renamer leaves this flag unchanged, to record the way
-- the user wrote it originally, so that the printer can
-- print it as the user wrote it
[HsTyVarBndr name] -- With ImplicitForAll, this is the empty list
-- until the renamer fills in the variables
(HsContext name)
(HsType name)
......@@ -117,6 +122,7 @@ data HsType name
| HsKindSig (HsType name) -- (ty :: kind)
Kind -- A type with a kind signature
data HsExplicitForAll = Explicit | Implicit
-----------------------
-- Combine adjacent for-alls.
......@@ -128,18 +134,22 @@ data HsType name
--
-- A valid type must have one for-all at the top of the type, or of the fn arg types
mkHsForAllTy mtvs [] ty = mk_forall_ty mtvs ty
mkHsForAllTy mtvs ctxt ty = HsForAllTy mtvs ctxt ty
mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty
mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
mkHsForAllTy :: HsExplicitForAll -> [HsTyVarBndr name] -> HsContext name -> HsType name -> HsType name
-- Smart constructor for HsForAllTy
mkHsForAllTy exp tvs [] ty = mk_forall_ty exp tvs ty
mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
-- mk_forall_ty makes a pure for-all type (no context)
mk_forall_ty (Just []) ty = ty -- Explicit for-all with no tyvars
mk_forall_ty mtvs1 (HsParTy ty) = mk_forall_ty mtvs1 ty
mk_forall_ty mtvs1 (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus` mtvs2) ctxt ty
mk_forall_ty mtvs1 ty = HsForAllTy mtvs1 [] ty
mk_forall_ty Explicit [] ty = ty -- Explicit for-all with no tyvars
mk_forall_ty exp tvs (HsParTy ty) = mk_forall_ty exp tvs ty
mk_forall_ty exp1 tvs1 (HsForAllTy exp2 tvs2 ctxt ty) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
mk_forall_ty exp tvs ty = HsForAllTy exp tvs [] ty
mtvs1 `plus` Nothing = mtvs1
Nothing `plus` mtvs2 = mtvs2
(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
Implicit `plus` Implicit = Implicit
exp1 `plus` exp2 = Explicit
mkHsDictTy cls tys = HsPredTy (HsClassP cls tys)
mkHsIParamTy v ty = HsPredTy (HsIParam v ty)
......@@ -183,7 +193,8 @@ splitHsInstDeclTy
splitHsInstDeclTy inst_ty
= case inst_ty of
HsForAllTy (Just tvs) cxt1 tau
HsForAllTy _ tvs cxt1 tau -- The type vars should have been
-- computed by now, even if they were implicit
-> (tvs, cxt1++cxt2, cls, tys)
where
(cxt2, cls, tys) = split_tau tau
......@@ -226,8 +237,14 @@ pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name
| otherwise = hsep [ppr name, dcolon, pprParendKind kind]
pprHsForAll [] [] = empty
pprHsForAll tvs cxt = ptext SLIT("forall") <+> interppSP tvs <+> pprHsContext cxt
pprHsForAll exp tvs cxt
| show_forall = forall_part <+> pprHsContext cxt
| otherwise = pprHsContext cxt
where
show_forall = opt_PprStyle_Debug
|| (not (null tvs) && is_explicit)
is_explicit = case exp of {Explicit -> True; Implicit -> False}
forall_part = ptext SLIT("forall") <+> interppSP tvs <> dot
pprHsContext :: (Outputable name) => HsContext name -> SDoc
pprHsContext [] = empty
......@@ -264,16 +281,11 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty
-- (b) Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
prepare sty (HsParTy ty) = prepare sty ty
prepare sty (HsForAllTy _ cxt ty) | userStyle sty = (HsForAllTy Nothing cxt ty)
prepare sty ty = ty
ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
= maybeParen ctxt_prec pREC_FUN $
sep [pp_header, ppr_mono_ty pREC_TOP ty]
where
pp_header = case maybe_tvs of
Just tvs -> pprHsForAll tvs ctxt
Nothing -> pprHsContext ctxt
sep [pprHsForAll exp tvs ctxt, ppr_mono_ty pREC_TOP ty]
ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2
......
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.126 2003/10/09 11:59:02 simonpj Exp $
$Id: Parser.y,v 1.127 2003/10/21 12:54:21 simonpj Exp $
Haskell grammar.
......@@ -673,7 +673,8 @@ sigtypes :: { [RdrNameHsType] }
| sigtypes ',' sigtype { $3 : $1 }
sigtype :: { RdrNameHsType }
: ctype { mkHsForAllTy Nothing [] $1 }
: ctype { mkImplicitHsForAllTy [] $1 }
-- Wrap an Implicit forall if there isn't one there already
sig_vars :: { [RdrName] }
: sig_vars ',' var { $3 : $1 }
......@@ -684,8 +685,8 @@ sig_vars :: { [RdrName] }
-- A ctype is a for-all type
ctype :: { RdrNameHsType }
: 'forall' tv_bndrs '.' ctype { mkHsForAllTy (Just $2) [] $4 }
| context '=>' type { mkHsForAllTy Nothing $1 $3 }
: 'forall' tv_bndrs '.' ctype { mkExplicitHsForAllTy $2 [] $4 }
| context '=>' type { mkImplicitHsForAllTy $1 $3 }
-- A type of form (context => type) is an *implicit* HsForAllTy
| type { $1 }
......
......@@ -318,8 +318,8 @@ ifaceExtRdrName :: IfaceExtName -> RdrName
ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
add_forall tv (HsForAllTy (Just tvs) cxt t) = HsForAllTy (Just (tv:tvs)) cxt t
add_forall tv t = HsForAllTy (Just [tv]) [] t
add_forall tv (HsForAllTy exp tvs cxt t) = HsForAllTy exp (tv:tvs) cxt t
add_forall tv t = HsForAllTy Explicit [tv] [] t
happyError :: P a
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
......
......@@ -194,23 +194,22 @@ extract_ctxt ctxt acc = foldr extract_pred acc ctxt
extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
extract_pred (HsIParam n ty) acc = extract_ty ty acc
extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsListTy ty) acc = extract_ty ty acc
extract_ty (HsPArrTy ty) acc = extract_ty ty acc
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 cx ty) acc = extract_ctxt cx (extract_ty ty acc)
extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsParTy ty) acc = extract_ty ty acc
-- Generics
extract_ty (HsNumTy num) acc = acc
extract_ty (HsKindSig ty k) acc = extract_ty ty acc
extract_ty (HsForAllTy (Just tvs) ctxt ty)
extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsListTy ty) acc = extract_ty ty acc
extract_ty (HsPArrTy ty) acc = extract_ty ty acc
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 (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsParTy ty) acc = extract_ty ty acc
extract_ty (HsNumTy num) acc = acc
extract_ty (HsKindSig ty k) acc = extract_ty ty acc
extract_ty (HsForAllTy exp [] cx ty) acc = extract_ctxt cx (extract_ty ty acc)
extract_ty (HsForAllTy exp tvs cx ty)
acc = acc ++
(filter (`notElem` locals) $
extract_ctxt ctxt (extract_ty ty []))
extract_ctxt cx (extract_ty ty []))
where
locals = hsTyVarNames tvs
......@@ -378,14 +377,14 @@ hsIfaceName rdr_name -- Qualify unqualifed occurrences
| otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
hsIfaceType :: HsType RdrName -> IfaceType
hsIfaceType (HsForAllTy mb_tvs cxt ty)
= foldr (IfaceForAllTy . hsIfaceTv) rho tvs
hsIfaceType (HsForAllTy exp tvs cxt ty)
= foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
where
rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt
tau = hsIfaceType ty
tvs = case mb_tvs of
Just tvs -> tvs
Nothing -> map UserTyVar (extractHsRhoRdrTyVars cxt ty)
tvs' = case exp of
Explicit -> tvs
Implicit -> map UserTyVar (extractHsRhoRdrTyVars cxt ty)
hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
......@@ -634,14 +633,14 @@ tyConToDataCon tc
checkInstType :: RdrNameHsType -> P RdrNameHsType
checkInstType t
= case t of
HsForAllTy tvs ctxt ty ->
HsForAllTy exp tvs ctxt ty ->
checkDictTy ty [] >>= \ dict_ty ->
return (HsForAllTy tvs ctxt dict_ty)
return (HsForAllTy exp tvs ctxt dict_ty)
HsParTy ty -> checkInstType ty
ty -> checkDictTy ty [] >>= \ dict_ty->
return (HsForAllTy Nothing [] dict_ty)
return (HsForAllTy Implicit [] [] dict_ty)
checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
checkTyVars tvs
......@@ -769,7 +768,7 @@ checkPat e [] = case e of
-- but they aren't explicit forall points. Hence
-- we have to remove the implicit forall here.
let t' = case t of
HsForAllTy Nothing [] ty -> ty
HsForAllTy Implicit _ [] ty -> ty
other -> other
in
return (SigPatIn e t')
......
......@@ -86,11 +86,10 @@ extractHsTyNames ty
get (HsNumTy n) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsKindSig ty k) = get ty
get (HsForAllTy (Just tvs)
get (HsForAllTy _ tvs
ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
`minusNameSet`
mkNameSet (hsTyVarNames tvs)
get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty)
extractHsTyNames_s :: [RenamedHsType] -> NameSet
extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
......
......@@ -75,7 +75,7 @@ want a gratuitous knot.
\begin{code}
rnHsType :: SDoc -> RdrNameHsType -> RnM RenamedHsType
rnHsType doc (HsForAllTy Nothing ctxt ty)
rnHsType doc (HsForAllTy Implicit _ ctxt ty)
-- Implicit quantifiction in source code (no kinds on tyvars)
-- Given the signature C => T we universally quantify
-- over FV(T) \ {in-scope-tyvars}
......@@ -89,9 +89,9 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
-- class C a where { op :: a -> a }
forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned
in
rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
rnForAll doc Implicit (map UserTyVar forall_tyvars) ctxt ty
rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau)
-- Explicit quantification.
-- Check that the forall'd tyvars are actually
-- mentioned in the type, and produce a warning if not
......@@ -103,7 +103,7 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
warn_guys = filter (`notElem` mentioned) forall_tyvar_names
in
mappM_ (forAllWarn doc tau) warn_guys `thenM_`
rnForAll doc forall_tyvars ctxt tau
rnForAll doc Explicit forall_tyvars ctxt tau
rnHsType doc (HsTyVar tyvar)
= lookupOccRn tyvar `thenM` \ tyvar' ->
......@@ -167,11 +167,11 @@ rnHsTypes doc tys = mappM (rnHsType doc) tys
\begin{code}
rnForAll doc forall_tyvars ctxt ty
rnForAll doc exp forall_tyvars ctxt ty
= bindTyVarsRn doc forall_tyvars $ \ new_tyvars ->
rnContext doc ctxt `thenM` \ new_ctxt ->
rnHsType doc ty `thenM` \ new_ty ->
returnM (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
returnM (HsForAllTy exp new_tyvars new_ctxt new_ty)
\end{code}
......
......@@ -544,7 +544,7 @@ checkSigsTyVars qtvs sigs
where
check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
= addSrcLoc src_loc $
addErrCtxt (ptext SLIT("When checking the type signature for")
addErrCtxt (ptext SLIT("In the type signature for")
<+> quotes (ppr id)) $
addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $
checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars
......
......@@ -12,10 +12,11 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..),
import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..),
HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..),
HsExplicitForAll(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isPragSig, placeHolderType, mkHsForAllTy
isPragSig, placeHolderType, mkExplicitHsForAllTy
)
import BasicTypes ( RecFlag(..), NewOrData(..) )
import RnHsSyn ( RenamedTyClDecl, RenamedSig,
......@@ -699,8 +700,12 @@ groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
eqPatType :: HsType Name -> HsType Name -> Bool
-- A very simple equality function, only for
-- type patterns in generic function definitions.
eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2
eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2
eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 && op1 == op2
eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
eqPatType (HsParTy t1) t2 = t1 `eqPatType` t2
eqPatType t1 (HsParTy t2) = t1 `eqPatType` t2
eqPatType _ _ = False
---------------------------------
......@@ -717,7 +722,7 @@ mkGenericInstance clas loc (hs_ty, binds)
-- works in the standard way
let
sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
hs_forall_ty = mkHsForAllTy (Just sig_tvs) [] hs_ty
hs_forall_ty = mkExplicitHsForAllTy sig_tvs [] hs_ty
in
-- Type-check the instance type, and check its form
tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty ->
......@@ -798,7 +803,7 @@ dupGenericInsts tc_inst_infos
ptext SLIT("All the type patterns for a generic type constructor must be identical")
]
where
ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst)
mixedGenericErr op
= ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
......
......@@ -986,7 +986,7 @@ caseScrutCtxt expr
= hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
exprSigCtxt expr
= hang (ptext SLIT("When checking the type signature of the expression:"))
= hang (ptext SLIT("In the type signature of the expression:"))
4 (ppr expr)
exprCtxt expr
......
......@@ -1167,7 +1167,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
get_tag_rhs = ExprWithTySig
(HsLam (mkSimpleHsAlt (VarPat a_RDR)
(HsApp (HsVar getTag_RDR) a_Expr)))
(HsForAllTy (Just (map UserTyVar tvs)) [] con2tag_ty)
(mkExplicitHsForAllTy (map UserTyVar tvs) [] con2tag_ty)
con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon))
(map HsTyVar tvs)
......
......@@ -32,14 +32,14 @@ import TcEnv ( tcExtendTyVarEnv, tcExtendTyVarKindEnv,
TyThing(..), TcTyThing(..),
getInLocalScope
)
import TcMType ( newKindVar, tcInstType, newMutTyVar,
import TcMType ( newKindVar, newOpenTypeKind, tcInstType, newMutTyVar,
zonkTcType, zonkTcKindToKind,
checkValidType, UserTypeCtxt(..), pprHsSigCtxt
)
import TcUnify ( unifyKind, unifyFunKind, unifyTypeKind )
import TcUnify ( unifyKind, unifyFunKind )
import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..),
TcTyVar, TcKind, TcThetaType, TcTauType,
mkTyVarTy, mkTyVarTys, mkFunTy,
mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind,
mkForAllTys, mkFunTys, tcEqType, isPredTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
liftedTypeKind, unliftedTypeKind, eqKind,
......@@ -204,15 +204,21 @@ tcHsKindedContext hs_theta = mappM dsHsPred hs_theta
\begin{code}
---------------------------
kcLiftedType :: HsType Name -> TcM (HsType Name)
-- The type ty must be a *lifted* *type*
-- The type ty must be a *lifted* *type*
kcLiftedType ty = kcCheckHsType ty liftedTypeKind
---------------------------
kcTypeType :: HsType Name -> TcM (HsType Name)
-- The type ty must be a *type*, but it can be lifted or unlifted
-- The type ty must be a *type*, but it can be lifted or unlifted
-- Be sure to use checkExpectedKind, rather than simply unifying
-- with (Type bx), because it gives better error messages
kcTypeType ty
= kcHsType ty `thenM` \ (ty', kind) ->
unifyTypeKind kind `thenM_`
if isTypeKind kind then
return ty'
else
newOpenTypeKind `thenM` \ type_kind ->
checkExpectedKind (ppr ty) kind type_kind `thenM_`
returnM ty'
---------------------------
......@@ -292,14 +298,14 @@ kcHsType (HsPredTy pred)
= kcHsPred pred `thenM` \ pred' ->
returnM (HsPredTy pred', liftedTypeKind)
kcHsType (HsForAllTy (Just tv_names) context ty)
kcHsType (HsForAllTy exp tv_names context ty)
= kcHsTyVars tv_names $ \ tv_names' ->
kcHsContext context `thenM` \ ctxt' ->
kcLiftedType ty `thenM` \ ty' ->
-- The body of a forall must be of kind *
-- In principle, I suppose, we could allow unlifted types,
-- but it seems simpler to stick to lifted types for now.
returnM (HsForAllTy (Just tv_names') ctxt' ty', liftedTypeKind)
returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind)
---------------------------
kcApps :: TcKind -- Function kind
......@@ -483,7 +489,7 @@ dsHsType (HsPredTy pred)
= dsHsPred pred `thenM` \ pred' ->
returnM (mkPredTy pred')
dsHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty)
dsHsType full_ty@(HsForAllTy exp tv_names ctxt ty)
= tcTyVarBndrs tv_names $ \ tyvars ->
mappM dsHsPred ctxt `thenM` \ theta ->
dsHsType ty `thenM` \ tau ->
......
......@@ -680,9 +680,9 @@ simplified: only zeze2 is extracted and its body is simplified.
\begin{code}
instDeclCtxt1 hs_inst_ty
= inst_decl_ctxt (case hs_inst_ty of
HsForAllTy _ _ (HsPredTy pred) -> ppr pred
HsPredTy pred -> ppr pred
other -> ppr hs_inst_ty) -- Don't expect this
HsForAllTy _ _ _ (HsPredTy pred) -> ppr pred
HsPredTy pred -> ppr pred
other -> ppr hs_inst_ty) -- Don't expect this
instDeclCtxt2 dfun_ty
= inst_decl_ctxt (ppr (mkClassPred cls tys))
where
......
......@@ -14,7 +14,7 @@ module TcMType (
newTyVar, newSigTyVar,
newTyVarTy, -- Kind -> TcM TcType
newTyVarTys, -- Int -> Kind -> TcM [TcType]
newKindVar, newKindVars, newBoxityVar,
newKindVar, newKindVars, newOpenTypeKind,
putTcTyVar, getTcTyVar,
newMutTyVar, readMutTyVar, writeMutTyVar,
......@@ -49,7 +49,7 @@ import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see repres
)
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
tcEqType, tcCmpPred, isClassPred,
tcEqType, tcCmpPred, isClassPred, mkTyConApp, typeCon,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitTyConApp_maybe, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
......@@ -134,6 +134,10 @@ newBoxityVar :: TcM TcKind -- Really TcBoxity
newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx"))
superBoxity VanillaTv `thenM` \ kv ->
returnM (TyVarTy kv)
newOpenTypeKind :: TcM TcKind
newOpenTypeKind = newBoxityVar `thenM` \ bx_var ->
returnM (mkTyConApp typeCon [bx_var])
\end{code}
......
......@@ -86,7 +86,7 @@ module TcType (
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
isTypeKind, isAnyTypeKind,
isTypeKind, isAnyTypeKind, typeCon,
Type, PredType(..), ThetaType,
mkForAllTy, mkForAllTys,
......@@ -117,7 +117,7 @@ import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tyVarsOfTheta, Kind, Type, PredType(..),
ThetaType, unliftedTypeKind,
ThetaType, unliftedTypeKind, typeCon,
liftedTypeKind, openTypeKind, mkArrowKind,
mkArrowKinds, mkForAllTy, mkForAllTys,
defaultKind, isTypeKind, isAnyTypeKind,
......
......@@ -11,7 +11,7 @@ module TcUnify (
-- Various unifications
unifyTauTy, unifyTauTyList, unifyTauTyLists,
unifyKind, unifyKinds, unifyTypeKind, unifyFunKind,
unifyKind, unifyKinds, unifyFunKind,
--------------------------------
-- Holes
......@@ -47,7 +47,7 @@ import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
)
import Inst ( newDicts, instToId, tcInstCall )
import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar,
newTyVarTy, newTyVarTys, newBoxityVar,
newTyVarTy, newTyVarTys, newOpenTypeKind,
zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV )
import TcSimplify ( tcSimplifyCheck )
import TysWiredIn ( listTyCon, parrTyCon, tupleTyCon )
......@@ -921,8 +921,8 @@ unifyTypeKind ty@(TyVarTy tyvar)
= getTcTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Just ty' -> unifyTypeKind ty'
Nothing -> newBoxityVar `thenM` \ bx_var ->
putTcTyVar tyvar (mkTyConApp typeCon [bx_var]) `thenM_`
Nothing -> newOpenTypeKind `thenM` \ kind ->
putTcTyVar tyvar kind `thenM_`
returnM ()
unifyTypeKind 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