Commit 836b1e90 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Keep track of explicit kinding in HsTyVarBndr; plus fix Trac #3845

To print HsTypes correctly we should remember whether the Kind on
a HsTyVarBndr came from type inference, or was put there by the
user.  See Note [Printing KindedTyVars] in HsTypes.  So instead of
changing a UserTyVar to a KindedTyVar during kind checking, we
simply add a PostTcKind to the UserTyVar.

The change was provoked by Trac #3830, although other changes
mean that #3830 gets a diferent and better error message now.
So this patch is simply doing the Right Thing for the future.

This patch also fixes Trac #3845, which was caused by a *type splice*
not remembering the free *term variables* mentioned in it.  Result
was that we build a 'let' when it should have been 'letrec'.
Hence a new FreeVars field in HsSpliceTy.

While I was at it, I got rid of HsSpliceTyOut and use a PostTcKind
on HsSpliceTy instead, just like on the UserTyVar.
parent d8453ba7
......@@ -536,9 +536,10 @@ lookupTyVarBinds tvs m =
--
repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
repTyVarBndrWithKind (L _ (UserTyVar _)) = repPlainTV
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) =
\nm -> repKind ki >>= repKindedTV nm
repTyVarBndrWithKind (L _ (UserTyVar {})) nm
= repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
= repKind ki >>= repKindedTV nm
-- represent a type context
--
......@@ -632,9 +633,9 @@ repTy (HsKindSig t k) = do
t1 <- repLTy t
k1 <- repKind k
repTSig t1 k1
repTy (HsSpliceTy splice) = repSplice splice
repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
repTy (HsSpliceTy splice _ _) = repSplice splice
repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
--
......
......@@ -641,7 +641,7 @@ cvtTvs tvs = mapM cvt_tv tvs
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tName nm
; returnL $ UserTyVar nm'
; returnL $ UserTyVar nm' placeHolderKind
}
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
......
......@@ -698,7 +698,7 @@ data ConDecl name
-- ^ Constructor name. This is used for the DataCon itself, and for
-- the user-callable wrapper Id.
, con_explicit :: HsExplicitForAll
, con_explicit :: HsExplicitFlag
-- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
, con_qvars :: [LHsTyVarBndr name]
......
......@@ -9,7 +9,7 @@ HsTypes: Abstract syntax: user-defined types
module HsTypes (
HsType(..), LHsType,
HsTyVarBndr(..), LHsTyVarBndr,
HsExplicitForAll(..),
HsExplicitFlag(..),
HsContext, LHsContext,
HsPred(..), LHsPred,
HsQuasiQuote(..),
......@@ -21,20 +21,21 @@ module HsTypes (
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames, replaceTyVarName,
hsTyVarKind, hsTyVarNameKind,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy, splitHsFunType,
-- Type place holder
PostTcType, placeHolderType,
PostTcType, placeHolderType, PostTcKind, placeHolderKind,
-- Printing
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
) where
import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
import NameSet( FreeVars )
import Type
import Coercion
import HsDoc
import BasicTypes
import SrcLoc
......@@ -51,6 +52,7 @@ import FastString
%************************************************************************
\begin{code}
type PostTcKind = Kind
type PostTcType = Type -- Used for slots in the abstract syntax
-- where we want to keep slot for a type
-- to be added by the type checker...but
......@@ -58,6 +60,9 @@ type PostTcType = Type -- Used for slots in the abstract syntax
placeHolderType :: PostTcType -- Used before typechecking
placeHolderType = panic "Evaluated the place holder for a PostTcType"
placeHolderKind :: PostTcKind -- Used before typechecking
placeHolderKind = panic "Evaluated the place holder for a PostTcKind"
\end{code}
%************************************************************************
......@@ -134,7 +139,7 @@ data HsPred name = HsClassP name [LHsType name] -- class constraint
type LHsType name = Located (HsType name)
data HsType name
= HsForAllTy HsExplicitForAll -- Renamer leaves this flag unchanged, to record the way
= HsForAllTy HsExplicitFlag -- 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
[LHsTyVarBndr name] -- With ImplicitForAll, this is the empty list
......@@ -179,20 +184,18 @@ data HsType name
| HsKindSig (LHsType name) -- (ty :: kind)
Kind -- A type with a kind signature
| HsSpliceTy (HsSplice name)
| HsQuasiQuoteTy (HsQuasiQuote name)
| HsDocTy (LHsType name) LHsDocString -- A documented type
| HsSpliceTy (HsSplice name)
FreeVars -- Variables free in the splice (filled in by renamer)
PostTcKind
| HsSpliceTyOut Kind -- Used just like KindedTyVar, just between
-- kcHsType and dsHsType
| HsDocTy (LHsType name) LHsDocString -- A documented type
| HsBangTy HsBang (LHsType name) -- Bang-style type annotations
| HsRecTy [ConDeclField name] -- Only in data type declarations
data HsExplicitForAll = Explicit | Implicit
data HsExplicitFlag = Explicit | Implicit
data ConDeclField name -- Record fields have Haddoc docs on them
= ConDeclField { cd_fld_name :: Located name,
......@@ -215,13 +218,13 @@ mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -
mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty
mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
mkHsForAllTy :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
-- Smart constructor for HsForAllTy
mkHsForAllTy exp tvs (L _ []) 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 :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsType name -> HsType name
mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty
mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty
......@@ -231,7 +234,7 @@ mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty
-- (see the sigtype production in Parser.y.pp)
-- so that (forall. ty) isn't implicitly quantified
plus :: HsExplicitForAll -> HsExplicitForAll -> HsExplicitForAll
plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag
Implicit `plus` Implicit = Implicit
_ `plus` _ = Explicit
......@@ -244,16 +247,29 @@ hsExplicitTvs _ = []
type LHsTyVarBndr name = Located (HsTyVarBndr name)
data HsTyVarBndr name
= UserTyVar name
| KindedTyVar name Kind
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
= UserTyVar -- No explicit kinding
name -- See Note [Printing KindedTyVars]
PostTcKind
| KindedTyVar
name
Kind
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
hsTyVarName :: HsTyVarBndr name -> name
hsTyVarName (UserTyVar n) = n
hsTyVarName (UserTyVar n _) = n
hsTyVarName (KindedTyVar n _) = n
hsTyVarKind :: HsTyVarBndr name -> Kind
hsTyVarKind (UserTyVar _ k) = k
hsTyVarKind (KindedTyVar _ k) = k
hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind)
hsTyVarNameKind (UserTyVar n k) = (n,k)
hsTyVarNameKind (KindedTyVar n k) = (n,k)
hsLTyVarName :: LHsTyVarBndr name -> name
hsLTyVarName = hsTyVarName . unLoc
......@@ -270,7 +286,7 @@ hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
hsLTyVarLocNames = map hsLTyVarLocName
replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
replaceTyVarName (UserTyVar _) n' = UserTyVar n'
replaceTyVarName (UserTyVar _ k) n' = UserTyVar n' k
replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k
\end{code}
......@@ -316,8 +332,8 @@ instance (OutputableBndr name) => Outputable (HsType name) where
ppr ty = pprHsType ty
instance (Outputable name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar name) = ppr name
ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind
ppr (UserTyVar name _) = ppr name
ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind]
instance OutputableBndr name => Outputable (HsPred name) where
ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys)
......@@ -328,11 +344,7 @@ instance OutputableBndr name => Outputable (HsPred name) where
pprLHsType :: OutputableBndr name => LHsType name -> SDoc
pprLHsType = pprParendHsType . unLoc
pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name
| otherwise = hsep [ppr name, dcolon, pprParendKind kind]
pprHsForAll :: OutputableBndr name => HsExplicitForAll -> [LHsTyVarBndr name] -> LHsContext name -> SDoc
pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc
pprHsForAll exp tvs cxt
| show_forall = forall_part <+> pprHsContext (unLoc cxt)
| otherwise = pprHsContext (unLoc cxt)
......@@ -358,6 +370,17 @@ pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
\end{code}
Note [Printing KindedTyVars]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trac #3830 reminded me that we should really only print the kind
signature on a KindedTyVar if the kind signature was put there by the
programmer. During kind inference GHC now adds a PostTcKind to UserTyVars,
rather than converting to KindedTyVars as before.
(As it happens, the message in #3830 comes out a different way now,
and the problem doesn't show up; but having the flag on a KindedTyVar
seems like the Right Thing anyway.)
\begin{code}
pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
pREC_TOP = 0 -- type in ParseIface.y
......@@ -408,8 +431,7 @@ ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPredTy pred) = ppr pred
ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s) = pprSplice s
ppr_mono_ty _ (HsSpliceTyOut k) = text "<splicety>" <> dcolon <> ppr k
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen ctxt_prec pREC_CON $
......
......@@ -28,6 +28,7 @@ import Coercion
import Type
import DataCon
import Name
import NameSet
import BasicTypes
import SrcLoc
import FastString
......@@ -183,6 +184,9 @@ mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
mkHsSplice e = HsSplice unqualSplice e
mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
-- A name (uniquified later) to
......@@ -201,7 +205,7 @@ mkHsString s = HsString (mkFastString s)
-------------
userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
\end{code}
......
......@@ -1014,11 +1014,9 @@ atype :: { LHsType RdrName }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) }
| quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) }
| '$(' exp ')' { LL $ HsSpliceTy (mkHsSplice $2 ) }
| TH_ID_SPLICE { LL $ HsSpliceTy (mkHsSplice
(L1 $ HsVar (mkUnqual varName
(getTH_ID_SPLICE $1)))) } -- $x
| '$(' exp ')' { LL $ mkHsSpliceTy $2 }
| TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
mkUnqual varName (getTH_ID_SPLICE $1) }
-- Generics
| INTEGER { L1 (HsNumTy (getINTEGER $1)) }
......@@ -1046,7 +1044,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
: tyvar { L1 (UserTyVar (unLoc $1)) }
: tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2)
(unLoc $4)) }
......@@ -1364,8 +1362,8 @@ aexp2 :: { LHsExpr RdrName }
-- Template Haskell Extension
| TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice
(L1 $ HsVar (mkUnqual varName
(getTH_ID_SPLICE $1)))) } -- $x
| '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp )
(getTH_ID_SPLICE $1)))) }
| '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) }
| TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) }
......
......@@ -128,7 +128,6 @@ extract_lty (L loc ty) acc
HsNumTy _ -> acc
HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
HsSpliceTy {} -> acc -- Type splices mention no type variables
HsSpliceTyOut {} -> acc -- Type splices mention no type variables
HsKindSig ty _ -> extract_lty ty acc
HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
......@@ -503,8 +502,7 @@ checkTParams is_family tparams
= do { tyvars <- checkTyVars tparams
; return (tyvars, Nothing) }
| otherwise -- Family case (b)
= do { let tyvars = [L l (UserTyVar tv)
| L l tv <- extractHsTysRdrTyVars tparams]
= do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
; return (tyvars, Just tparams) }
checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
......@@ -519,7 +517,7 @@ checkTyVars tparms = mapM chk tparms
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
| isRdrTyVar tv = return (L l (KindedTyVar tv k))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
chk (L l _) =
parseError l "Type found where type variable expected"
......
......@@ -68,9 +68,8 @@ extractHsTyNames ty
get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds)
get (HsNumTy _) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsSpliceTy {}) = emptyNameSet -- Type splices mention no type variables
get (HsSpliceTyOut {}) = emptyNameSet -- Ditto
get (HsQuasiQuoteTy {}) = emptyNameSet -- Ditto
get (HsSpliceTy _ fvs _) = fvs
get (HsQuasiQuoteTy {}) = emptyNameSet
get (HsKindSig ty _) = getl ty
get (HsForAllTy _ tvs
ctxt ty) = (extractHsCtxtTyNames ctxt
......
......@@ -185,9 +185,9 @@ rnHsType doc (HsPredTy pred) = do
pred' <- rnPred doc pred
return (HsPredTy pred')
rnHsType _ (HsSpliceTy sp)
= do { (sp', _fvs) <- rnSplice sp -- ToDo: deal with fvs
; return (HsSpliceTy sp') }
rnHsType _ (HsSpliceTy sp _ k)
= do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs
; return (HsSpliceTy sp' fvs k) }
rnHsType doc (HsDocTy ty haddock_doc) = do
ty' <- rnLHsType doc ty
......@@ -200,7 +200,6 @@ rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHC
rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
; rnHsType doc (unLoc ty) }
#endif
rnHsType _ (HsSpliceTyOut {}) = panic "rnHsType"
rnLHsTypes :: SDoc -> [LHsType RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
......@@ -209,7 +208,7 @@ rnLHsTypes doc tys = mapM (rnLHsType doc) tys
\begin{code}
rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
-> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
......
......@@ -528,7 +528,8 @@ mkGenericInstance clas (hs_ty, binds) = do
-- and wrap them as forall'd tyvars, so that kind inference
-- works in the standard way
let
sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
extractHsTyVars (noLoc hs_ty)
hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
-- Type-check the instance type, and check its form
......
......@@ -319,13 +319,10 @@ tcExtendKindEnv things thing_inside
upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r
tcExtendKindEnvTvs bndrs thing_inside
= updLclEnv upd thing_inside
where
upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
extend env = extendNameEnvList env pairs
pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
= tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
(thing_inside bndrs)
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
......
......@@ -1598,7 +1598,8 @@ genAuxBind loc (GenCon2Tag tycon)
get_tag_rhs = L loc $ ExprWithTySig
(nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
(nlHsApp (nlHsVar getTag_RDR) a_Expr)))
(noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
(noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs))
(noLoc []) con2tag_ty))
con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
`nlHsFunTy`
......
......@@ -16,7 +16,7 @@ module TcHsType (
-- Typechecking kinded types
tcHsKindedContext, tcHsKindedType, tcHsBangType,
tcTyVarBndrs, dsHsType, tcLHsConResTy,
tcTyVarBndrs, dsHsType,
tcDataKindSig, ExpKind(..), EkCtxt(..),
-- Pattern type signatures
......@@ -419,12 +419,11 @@ kc_hs_type ty@(HsRecTy _)
-- should have been removed by now
#ifdef GHCI /* Only if bootstrapped */
kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
kc_hs_type (HsSpliceTy sp fvs _) = kcSpliceType sp fvs
#else
kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
#endif
kc_hs_type (HsSpliceTyOut {}) = panic "kc_hs_type" -- Should not happen at all
kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type" -- Eliminated by renamer
-- remove the doc nodes here, no need to worry about the location since
......@@ -624,11 +623,10 @@ ds_type (HsForAllTy _ tv_names ctxt ty)
ds_type (HsDocTy ty _) -- Remove the doc comment
= dsHsType ty
ds_type (HsSpliceTyOut kind)
ds_type (HsSpliceTy _ _ kind)
= do { kind' <- zonkTcKindToKind kind
; newFlexiTyVarTy kind' }
ds_type (HsSpliceTy {}) = panic "ds_type"
ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer
dsHsTypes :: [LHsType Name] -> TcM [Type]
......@@ -684,35 +682,7 @@ dsHsPred (HsIParam name ty)
}
\end{code}
GADT constructor signatures
\begin{code}
tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
tcLHsConResTy (L span res_ty)
= setSrcSpan span $
case get_args res_ty [] of
(HsTyVar tc_name, args)
-> do { args' <- mapM dsHsType args
; thing <- tcLookup tc_name
; case thing of
AGlobal (ATyCon tc) -> return (tc, args')
_ -> failWithTc (badGadtDecl res_ty) }
_ -> failWithTc (badGadtDecl res_ty)
where
-- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe
-- because that causes a black hole, and for good reason. Building
-- the type means expanding type synonyms, and we can't do that
-- inside the "knot". So we have to work by steam.
get_args (HsAppTy (L _ fun) arg) args = get_args fun (arg:args)
get_args (HsParTy (L _ ty)) args = get_args ty args
get_args (HsOpTy ty1 (L _ tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
get_args ty args = (ty, args)
badGadtDecl :: HsType Name -> SDoc
badGadtDecl ty
= hang (ptext (sLit "Malformed constructor result type:"))
2 (ppr ty)
addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a
-- Wrap a context around only if we want to show that contexts.
addKcTypeCtxt (L _ (HsPredTy _)) thing = thing
......@@ -735,14 +705,14 @@ kcHsTyVars :: [LHsTyVarBndr Name]
-> ([LHsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated
-- They scope over the thing inside
-> TcM r
kcHsTyVars tvs thing_inside = do
bndrs <- mapM (wrapLocM kcHsTyVar) tvs
tcExtendKindEnvTvs bndrs (thing_inside bndrs)
kcHsTyVars tvs thing_inside
= do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs
; tcExtendKindEnvTvs kinded_tvs thing_inside }
kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
-- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it
kcHsTyVar (UserTyVar name) = KindedTyVar name <$> newKindVar
kcHsTyVar (KindedTyVar name kind) = return (KindedTyVar name kind)
kcHsTyVar (UserTyVar name _) = UserTyVar name <$> newKindVar
kcHsTyVar tv@(KindedTyVar {}) = return tv
------------------
tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking
......@@ -754,10 +724,9 @@ tcTyVarBndrs bndrs thing_inside = do
tyvars <- mapM (zonk . unLoc) bndrs
tcExtendTyVarEnv tyvars (thing_inside tyvars)
where
zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind
; return (mkTyVar name kind') }
zonk (UserTyVar name) = WARN( True, ptext (sLit "Un-kinded tyvar") <+> ppr name )
return (mkTyVar name liftedTypeKind)
zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind
; return (mkTyVar name kind') }
zonk (KindedTyVar name kind) = return (mkTyVar name kind)
-----------------------------------
tcDataKindSig :: Maybe Kind -> TcM [TyVar]
......@@ -867,9 +836,9 @@ tcHsPatSigType ctxt hs_ty
-- should be bound by the pattern signature
in_scope <- getInLocalScope
; let span = getLoc hs_ty
sig_tvs = [ L span (UserTyVar n)
| n <- nameSetToList (extractHsTyVars hs_ty),
not (in_scope n) ]
sig_tvs = userHsTyVarBndrs $ map (L span) $
filterOut in_scope $
nameSetToList (extractHsTyVars hs_ty)
; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty
; checkValidType ctxt sig_ty
......
......@@ -46,6 +46,7 @@ import TcIface
import TypeRep
import Name
import NameEnv
import NameSet
import PrelNames
import HscTypes
import OccName
......@@ -284,7 +285,7 @@ The predicate we use is TcEnv.thTopLevelId.
tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
-- None of these functions add constraints to the LIE
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
......@@ -300,7 +301,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
kcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
......@@ -495,7 +496,7 @@ tcTopSpliceExpr tc_action
Very like splicing an expression, but we don't yet share code.
\begin{code}
kcSpliceType (HsSplice name hs_expr)
kcSpliceType splice@(HsSplice name hs_expr) fvs
= setSrcSpan (getLoc hs_expr) $ do
{ stage <- getStage
; case stage of {
......@@ -518,11 +519,8 @@ kcSpliceType (HsSplice name hs_expr)
-- Here (h 4) :: Q Type
-- but $(h 4) :: a i.e. any type, of any kind
-- We return a HsSpliceTyOut, which serves to convey the kind to
-- the ensuing TcHsType.dsHsType, which makes up a non-committal
-- type variable of a suitable kind
; kind <- newKindVar
; return (HsSpliceTyOut kind, kind)
; return (HsSpliceTy splice fvs kind, kind)
}}}
kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
......
......@@ -3,6 +3,7 @@ module TcSplice where
import HsSyn ( HsSplice, HsBracket, HsQuasiQuote,
HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl )
import Name ( Name )
import NameSet ( FreeVars )
import RdrName ( RdrName )
import TcRnTypes( TcM, TcId )
import TcType ( BoxyRhoType, TcKind )
......@@ -13,7 +14,7 @@ tcSpliceExpr :: HsSplice Name
-> BoxyRhoType
-> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name
kcSpliceType :: HsSplice Name -> FreeVars
-> TcM (HsType Name, TcKind)
tcBracket :: HsBracket Name
......
......@@ -481,7 +481,7 @@ getInitialKind decl
; res_kind <- mk_res_kind decl
; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
where
mk_arg_kind (UserTyVar _) = newKindVar
mk_arg_kind (UserTyVar _ _) = newKindVar
mk_arg_kind (KindedTyVar _ kind) = return kind
mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind
......@@ -513,7 +513,7 @@ kcSynDecl (AcyclicSCC (L loc decl))
<+> brackets (ppr k_tvs))
; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
(unLoc (tcdLName decl), tc_kind)) })
......@@ -521,10 +521,6 @@ kcSynDecl (CyclicSCC decls)
= do { recSynErr decls; failM } -- Fail here to avoid error cascade
-- of out-of-scope tycons
kindedTyVarKind :: LHsTyVarBndr Name -> Kind
kindedTyVarKind (L _ (KindedTyVar _ k)) = k
kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x)
------------------------------------------------------------------------
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
-- Not used for type synonyms (see kcSynDecl)
......@@ -566,14 +562,16 @@ kcTyClDeclBody decl thing_inside
= tcAddDeclCtxt decl $
do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
; let tc_kind = case tc_ty_thing of
AThing k -> k
_ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
AThing k -> k
_ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
(kinds, _) = splitKindFunTys tc_kind
hs_tvs = tcdTyVars decl
kinded_tvs = ASSERT( length kinds >= length hs_tvs )
[ L loc (KindedTyVar (hsTyVarName tv) k)
| (L loc tv, k) <- zip hs_tvs kinds]
; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) }
zipWith add_kind hs_tvs kinds
; tcExtendKindEnvTvs kinded_tvs thing_inside }
where
add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k)
add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
-- Kind check a data declaration, assuming that we already extended the
-- kind environment with the type variables of the left-hand side (these
......@@ -633,11 +631,13 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
-- default result kind is '*'
}
where
unifyClassParmKinds (L _ (KindedTyVar n k))
| Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind
| otherwise = return ()
unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x)
classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs]
unifyClassParmKinds (L _ tv)
| (n,k) <- hsTyVarNameKind tv
, Just classParmKind <- lookup n classTyKinds
= unifyKind k classParmKind
| otherwise = return ()
classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
kcFamilyDecl _ (TySynonym {}) -- type family defaults
= panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
......
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