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

5 files changed, 41 insertions, 24 deletions

diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 5c4045778a..de9f35a798 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -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, .. }
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index a4a9dfc5f6..c63a2e5c1d 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -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)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 1efb11e21b..19b5cfe405 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -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
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 2f397a06fc..122e510c6b 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -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}
 
 
@@ -316,6 +317,18 @@ 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
 tc_hs_type (HsDocTy 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
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index f5741997b0..541b309684 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -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>