Commit 9991890d authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Ensure we produce a FunTy for functions (Trac #7312)

The issue here was with a function type written prefix
  (->) a b
where we were not generating a FunTy, which blew the
invariant that function types are always FunTys.  We
can't look at the TyCon directly because it may be
knot-tied, so we look at the name instead.
parent 55478b1e
...@@ -68,13 +68,14 @@ import TysWiredIn ...@@ -68,13 +68,14 @@ import TysWiredIn
import BasicTypes import BasicTypes
import SrcLoc import SrcLoc
import DynFlags ( ExtensionFlag( Opt_DataKinds ) ) import DynFlags ( ExtensionFlag( Opt_DataKinds ) )
import Unique
import UniqSupply import UniqSupply
import Outputable import Outputable
import FastString import FastString
import Util import Util
import Control.Monad ( unless, when, zipWithM ) import Control.Monad ( unless, when, zipWithM )
import PrelNames(ipClassName) import PrelNames( ipClassName, funTyConKey )
\end{code} \end{code}
...@@ -315,6 +316,18 @@ tc_lhs_type (L span ty) exp_kind ...@@ -315,6 +316,18 @@ tc_lhs_type (L span ty) exp_kind
tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType] tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType]
tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds
------------------------------------------
tc_fun_type :: HsType Name -> LHsType Name -> LHsType Name -> ExpKind -> TcM TcType
-- We need to recognise (->) so that we can construct a FunTy,
-- *and* we need to do by looking at the Name, not the TyCon
-- (see Note [Zonking inside the knot]). For example,
-- consider f :: (->) Int Int (Trac #7312)
tc_fun_type ty ty1 ty2 exp_kind@(EK _ ctxt)
= do { ty1' <- tc_lhs_type ty1 (EK openTypeKind ctxt)
; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt)
; checkExpectedKind ty liftedTypeKind exp_kind
; return (mkFunTy ty1' ty2') }
------------------------------------------ ------------------------------------------
tc_hs_type :: HsType Name -> ExpKind -> TcM TcType tc_hs_type :: HsType Name -> ExpKind -> TcM TcType
tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind
...@@ -335,24 +348,30 @@ tc_hs_type hs_ty@(HsTyVar name) exp_kind ...@@ -335,24 +348,30 @@ tc_hs_type hs_ty@(HsTyVar name) exp_kind
; checkExpectedKind hs_ty k exp_kind ; checkExpectedKind hs_ty k exp_kind
; return ty } ; return ty }
tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind
= do { ty1' <- tc_lhs_type ty1 (EK openTypeKind ctxt) = tc_fun_type ty ty1 ty2 exp_kind
; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt)
; checkExpectedKind ty liftedTypeKind exp_kind
; return (mkFunTy ty1' ty2') }
tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind
| op `hasKey` funTyConKey
= tc_fun_type hs_ty ty1 ty2 exp_kind
| otherwise
= do { (op', op_kind) <- tcTyVar op = do { (op', op_kind) <- tcTyVar op
; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind ; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind
; return (mkNakedAppTys op' tys') } ; return (mkNakedAppTys op' tys') }
-- mkNakedAppTys: see Note [Zonking inside the knot] -- mkNakedAppTys: see Note [Zonking inside the knot]
tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind
= do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] | L _ (HsTyVar fun) <- fun_ty
; (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty , fun `hasKey` funTyConKey
, [fty1,fty2] <- arg_tys
= tc_fun_type hs_ty fty1 fty2 exp_kind
| otherwise
= do { (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty
; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind
; return (mkNakedAppTys fun_ty' arg_tys') } ; return (mkNakedAppTys fun_ty' arg_tys') }
-- mkNakedAppTys: see Note [Zonking inside the knot] -- mkNakedAppTys: see Note [Zonking inside the knot]
where
(fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
--------- Foralls --------- Foralls
tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind
......
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