Commit 56a2003a authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 83f5c6c6 4780cbc1
......@@ -258,6 +258,7 @@ collectContInfo blocks
where
(mb_argss, ret_offs) = mapAndUnzip get_cont blocks
get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
get_cont b =
case lastNode b of
CmmCall { cml_cont = Just l, .. }
......
......@@ -1481,7 +1481,7 @@ tyConToIfaceDecl env tycon
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
(env1, tyvars) = tidyTyVarBndrs env (tyConTyVars tycon)
(env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
to_ifsyn_rhs (SynFamilyTyCon a b) = SynFamilyTyCon a b
to_ifsyn_rhs (SynonymTyCon ty) = SynonymTyCon (tidyToIfaceType env1 ty)
......
......@@ -570,20 +570,17 @@ tcIfaceDataCons tycon_name tycon _ if_cons
= bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ name <- lookupIfaceTop occ
; eq_spec <- tcIfaceEqSpec spec
; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
-- At one stage I thought that this context checking *had*
-- to be lazy, because of possible mutual recursion between the
-- type and the classe:
-- E.g.
-- class Real a where { toRat :: a -> Ratio Integer }
-- data (Real a) => Ratio a = ...
-- But now I think that the laziness in checking class ops breaks
-- the loop, so no laziness needed
-- Read the argument types, but lazily to avoid faulting in
-- the component types unless they are really needed
; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args)
-- Read the context and argument types, but lazily for two reasons
-- (a) to avoid looking tugging on a recursive use of
-- the type itself, which is knot-tied
-- (b) to avoid faulting in the component types unless
-- they are really needed
; ~(eq_spec, theta, arg_tys) <- forkM (mk_doc name) $
do { eq_spec <- tcIfaceEqSpec spec
; theta <- tcIfaceCtxt ctxt
; arg_tys <- mapM tcIfaceType args
; return (eq_spec, theta, arg_tys) }
; lbl_names <- mapM lookupIfaceTop field_lbls
-- Remember, tycon is the representation tycon
......
......@@ -68,13 +68,14 @@ import TysWiredIn
import BasicTypes
import SrcLoc
import DynFlags ( ExtensionFlag( Opt_DataKinds ) )
import Unique
import UniqSupply
import Outputable
import FastString
import Util
import Control.Monad ( unless, when, zipWithM )
import PrelNames(ipClassName)
import PrelNames( ipClassName, funTyConKey )
\end{code}
......@@ -315,6 +316,18 @@ tc_lhs_type (L span ty) exp_kind
tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType]
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 (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind
......@@ -335,24 +348,30 @@ tc_hs_type hs_ty@(HsTyVar name) exp_kind
; checkExpectedKind hs_ty k exp_kind
; return ty }
tc_hs_type ty@(HsFunTy 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 ty@(HsFunTy ty1 ty2) exp_kind
= tc_fun_type ty ty1 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
; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind
; return (mkNakedAppTys op' tys') }
-- mkNakedAppTys: see Note [Zonking inside the knot]
tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind
= do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
; (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty
| L _ (HsTyVar fun) <- 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
; return (mkNakedAppTys fun_ty' arg_tys') }
-- mkNakedAppTys: see Note [Zonking inside the knot]
where
(fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
--------- Foralls
tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind
......
......@@ -632,7 +632,7 @@ type Typ
data TypView = Unit
| Arrow Typ Typ
view :: Type -> TypeView
view :: Typ -> TypView
-- additional operations for constructing Typ's ...
</programlisting>
......
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