[commit: ghc] master: Fix Trac #7506 (missing check for form of FFI type) (942939c)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/942939c050b0649430a2e41b026499efb46d5f17

>---------------------------------------------------------------

commit 942939c050b0649430a2e41b026499efb46d5f17
Author: Simon Peyton Jones <[email protected]>
Date:   Wed Dec 19 13:23:21 2012 +0000

    Fix Trac #7506 (missing check for form of FFI type)

>---------------------------------------------------------------

 compiler/typecheck/TcForeign.lhs |   12 ++++++++----
 1 files changed, 8 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 40fb3b2..c691bd0 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -47,7 +47,6 @@ import Platform
 import SrcLoc
 import Bag
 import FastString
-import Util
 
 import Control.Monad
 \end{code}
@@ -213,11 +212,11 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
 
 tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh l@(CLabel _))
-  = ASSERT( null arg_tys )
-    do checkCg checkCOrAsmOrLlvmOrInterp
+  -- Foreign import label
+  = do checkCg checkCOrAsmOrLlvmOrInterp
        -- NB check res_ty not sig_ty!
        --    In case sig_ty is (forall a. ForeignPtr a)
-       check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
+       check (null arg_tys && isFFILabelTy res_ty) (illegalForeignLabelErr sig_ty)
        cconv' <- checkCConv cconv
        return (CImport cconv' safety mh l)
 
@@ -483,6 +482,11 @@ check :: Bool -> MsgDoc -> TcM ()
 check True _       = return ()
 check _    the_err = addErrTc the_err
 
+illegalForeignLabelErr :: Type -> SDoc
+illegalForeignLabelErr ty
+  = vcat [ illegalForeignTyErr empty ty
+         , ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") ]
+
 illegalForeignTyErr :: SDoc -> Type -> SDoc
 illegalForeignTyErr arg_or_res ty
   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,