Handle newtypes and type functions correctly in FFI types; fixes #3008

You can now use type functions in FFI types.

Newtypes are now only looked through if the constructor is in scope.

compiler/deSugar/DsCCall.lhs

@@ -209,7 +209,7 @@ boxResult :: Type
 --	State# RealWorld -> (# State# RealWorld #)
 
 boxResult result_ty
-  | Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty
+  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
 	-- isIOType_maybe handles the case where the type is a 
 	-- simple wrapping of IO.  E.g.
 	-- 	newtype Wrap a = W (IO a)
@@ -236,7 +236,7 @@ boxResult result_ty
 	; let io_data_con = head (tyConDataCons io_tycon)
 	      toIOCon     = dataConWrapId io_data_con
 
-	      wrap the_call = mkCoerce (mkSymCo co) $
+	      wrap the_call =
 			      mkApps (Var toIOCon)
 			    	     [ Type io_res_ty, 
 			    	       Lam state_id $

compiler/deSugar/DsForeign.lhs

@@ -18,7 +18,6 @@ import DsMonad
 
 import HsSyn
 import DataCon
-import CoreUtils
 import CoreUnfold
 import Id
 import Literal
@@ -45,6 +44,7 @@ import Platform
 import Config
 import Constants
 import OrdList
+import Pair
 import Data.Maybe
 import Data.List
 \end{code}
@@ -84,14 +84,14 @@ dsForeigns fos = do
   where
    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
 
-   do_decl (ForeignImport id _ spec) = do
+   do_decl (ForeignImport id _ co spec) = do
       traceIf (text "fi start" <+> ppr id)
-      (bs, h, c) <- dsFImport (unLoc id) spec
+      (bs, h, c) <- dsFImport (unLoc id) co spec
       traceIf (text "fi end" <+> ppr id)
       return (h, c, [], bs)
 
-   do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do
-      (h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False
+   do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do
+      (h, c, _, _) <- dsFExport id co ext_nm cconv False
       return (h, c, [id], [])
 \end{code}
 
@@ -122,20 +122,22 @@ because it exposes the boxing to the call site.
 
 \begin{code}
 dsFImport :: Id
+          -> Coercion
           -> ForeignImport
           -> DsM ([Binding], SDoc, SDoc)
-dsFImport id (CImport cconv safety _ spec) = do
-    (ids, h, c) <- dsCImport id spec cconv safety
+dsFImport id co (CImport cconv safety _ spec) = do
+    (ids, h, c) <- dsCImport id co spec cconv safety
     return (ids, h, c)
 
 dsCImport :: Id
+          -> Coercion
           -> CImportSpec
           -> CCallConv
           -> Safety
           -> DsM ([Binding], SDoc, SDoc)
-dsCImport id (CLabel cid) cconv _ = do
-   let ty = idType id
-       fod = case tyConAppTyCon_maybe (repType ty) of
+dsCImport id co (CLabel cid) cconv _ = do
+   let ty = pFst $ coercionKind co
+       fod = case tyConAppTyCon_maybe ty of
              Just tycon
               | tyConUnique tycon == funPtrTyConKey ->
                  IsFunction
@@ -144,23 +146,24 @@ dsCImport id (CLabel cid) cconv _ = do
    ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
     let
         rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
+        rhs' = Cast rhs co
         stdcall_info = fun_type_arg_stdcall_info cconv ty
     in
-    return ([(id, rhs)], empty, empty)
+    return ([(id, rhs')], empty, empty)
 
-dsCImport id (CFunction target) cconv@PrimCallConv safety
-  = dsPrimCall id (CCall (CCallSpec target cconv safety))
-dsCImport id (CFunction target) cconv safety
-  = dsFCall id (CCall (CCallSpec target cconv safety))
-dsCImport id CWrapper cconv _
-  = dsFExportDynamic id cconv
+dsCImport id co (CFunction target) cconv@PrimCallConv safety
+  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
+dsCImport id co (CFunction target) cconv safety
+  = dsFCall id co (CCall (CCallSpec target cconv safety))
+dsCImport id co CWrapper cconv _
+  = dsFExportDynamic id co cconv
 
 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
 -- then we need to calculate the size of the arguments in order to add
 -- the @n suffix to the label.
 fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
 fun_type_arg_stdcall_info StdCallConv ty
-  | Just (tc,[arg_ty]) <- splitTyConApp_maybe (repType ty),
+  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
     tyConUnique tc == funPtrTyConKey
   = let
        (_tvs,sans_foralls)        = tcSplitForAllTys arg_ty
@@ -178,10 +181,10 @@ fun_type_arg_stdcall_info _other_conv _
 %************************************************************************
 
 \begin{code}
-dsFCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
-dsFCall fn_id fcall = do
+dsFCall :: Id -> Coercion -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsFCall fn_id co fcall = do
     let
-        ty                   = idType fn_id
+        ty                   = pFst $ coercionKind co
         (tvs, fun_ty)        = tcSplitForAllTys ty
         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
                 -- Must use tcSplit* functions because we want to
@@ -208,9 +211,10 @@ dsFCall fn_id fcall = do
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs
+        wrap_rhs'    = Cast wrap_rhs co
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
 
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, empty)
 \end{code}
 
 
@@ -228,10 +232,11 @@ kind of Id, or perhaps to bundle them with PrimOps since semantically and
 for calling convention they are really prim ops.
 
 \begin{code}
-dsPrimCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
-dsPrimCall fn_id fcall = do
+dsPrimCall :: Id -> Coercion -> ForeignCall
+           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsPrimCall fn_id co fcall = do
     let
-        ty                   = idType fn_id
+        ty                   = pFst $ coercionKind co
         (tvs, fun_ty)        = tcSplitForAllTys ty
         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
                 -- Must use tcSplit* functions because we want to
@@ -243,7 +248,8 @@ dsPrimCall fn_id fcall = do
     let
         call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
         rhs      = mkLams tvs (mkLams args call_app)
-    return ([(fn_id, rhs)], empty, empty)
+        rhs'     = Cast rhs co
+    return ([(fn_id, rhs')], empty, empty)
 
 \end{code}
 
@@ -267,7 +273,8 @@ the user-written Haskell function `@M.foo@'.
 \begin{code}
 dsFExport :: Id                 -- Either the exported Id,
                                 -- or the foreign-export-dynamic constructor
-          -> Type               -- The type of the thing callable from C
+          -> Coercion           -- Coercion between the Haskell type callable
+                                -- from C, and its representation type
           -> CLabelString       -- The name to export to C land
           -> CCallConv
           -> Bool               -- True => foreign export dynamic
@@ -279,8 +286,9 @@ dsFExport :: Id                 -- Either the exported Id,
                  , Int          -- size of args to stub function
                  )
 
-dsFExport fn_id ty ext_name cconv isDyn=  do
+dsFExport fn_id co ext_name cconv isDyn = do
     let
+       ty                              = pSnd $ coercionKind co
        (_tvs,sans_foralls)             = tcSplitForAllTys ty
        (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
        -- We must use tcSplits here, because we want to see
@@ -294,9 +302,8 @@ dsFExport fn_id ty ext_name cconv isDyn=  do
     (res_ty,             -- t
      is_IO_res_ty) <-    -- Bool
         case tcSplitIOType_maybe orig_res_ty of
-           Just (_ioTyCon, res_ty, _co) -> return (res_ty, True)
+           Just (_ioTyCon, res_ty) -> return (res_ty, True)
                    -- The function already returns IO t
-                   -- ToDo: what about the coercion?
            Nothing                    -> return (orig_res_ty, False)
                    -- The function returns t
 
@@ -339,9 +346,10 @@ f_helper(StablePtr s, HsBool b, HsInt i)
 
 \begin{code}
 dsFExportDynamic :: Id
+                 -> Coercion
                  -> CCallConv
                  -> DsM ([Binding], SDoc, SDoc)
-dsFExportDynamic id cconv = do
+dsFExportDynamic id co0 cconv = do
     fe_id <-  newSysLocalDs ty
     mod <- getModuleDs
     let
@@ -356,7 +364,7 @@ dsFExportDynamic id cconv = do
         export_ty     = mkFunTy stable_ptr_ty arg_ty
     bindIOId <- dsLookupGlobalId bindIOName
     stbl_value <- newSysLocalDs stable_ptr_ty
-    (h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True
+    (h_code, c_code, typestring, args_size) <- dsFExport id (Refl export_ty) fe_nm cconv True
     let
          {-
           The arguments to the external function which will
@@ -386,7 +394,6 @@ dsFExportDynamic id cconv = do
 
     let io_app = mkLams tvs                  $
                  Lam cback                   $
-                 mkCoerce (mkSymCo co) $
                  mkApps (Var bindIOId)
                         [ Type stable_ptr_ty
                         , Type res_ty
@@ -394,19 +401,18 @@ dsFExportDynamic id cconv = do
                         , Lam stbl_value ccall_adj
                         ]
 
-        fed = (id `setInlineActivation` NeverActive, io_app)
+        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
                -- Never inline the f.e.d. function, because the litlit
                -- might not be in scope in other modules.
 
     return ([fed], h_code, c_code)
 
  where
-  ty                       = idType id
+  ty                       = pFst (coercionKind co0)
   (tvs,sans_foralls)       = tcSplitForAllTys ty
   ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
-  Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
+  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
         -- Must have an IO type; hence Just
-        -- co : fn_res_ty ~ IO res_ty
 
 toCName :: Id -> String
 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))

compiler/deSugar/DsMeta.hs

@@ -324,7 +324,7 @@ repInstD' (L loc (InstDecl ty binds _ ats))	-- Ignore user pragmas for now
    Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
 
 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
-repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
+repForD (L loc (ForeignImport name typ _ (CImport cc s ch cis)))
  = do MkC name' <- lookupLOcc name
       MkC typ' <- repLTy typ
       MkC cc' <- repCCallConv cc

compiler/hsSyn/Convert.lhs

@@ -370,7 +370,7 @@ cvtForD (ImportF callconv safety from nm ty)
                                  (mkFastString (TH.nameBase nm)) from
   = do { nm' <- vNameL nm
        ; ty' <- cvtType ty
-       ; return (ForeignImport nm' ty' impspec)
+       ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
        }
   | otherwise
   = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
@@ -384,7 +384,7 @@ cvtForD (ExportF callconv as nm ty)
   = do	{ nm' <- vNameL nm
 	; ty' <- cvtType ty
 	; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
- 	; return $ ForeignExport nm' ty' e }
+ 	; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
 
 cvt_conv :: TH.Callconv -> CCallConv
 cvt_conv TH.CCall   = CCallConv

compiler/hsSyn/HsDecls.lhs

@@ -35,6 +35,7 @@ module HsDecls (
   SpliceDecl(..),
   -- ** Foreign function interface declarations
   ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
+  noForeignImportCoercionYet, noForeignExportCoercionYet,
   CImportSpec(..),
   -- ** Data-constructor declarations
   ConDecl(..), LConDecl, ResType(..), 
@@ -64,6 +65,7 @@ import NameSet
 import Name
 import {- Kind parts of -} Type
 import BasicTypes
+import Coercion
 import ForeignCall
 
 -- others:
@@ -911,9 +913,31 @@ instance (OutputableBndr name)
 type LForeignDecl name = Located (ForeignDecl name)
 
 data ForeignDecl name
-  = ForeignImport (Located name) (LHsType name) ForeignImport  -- defines name
-  | ForeignExport (Located name) (LHsType name) ForeignExport  -- uses name
+  = ForeignImport (Located name) -- defines this name
+                  (LHsType name) -- sig_ty
+                  Coercion       -- rep_ty ~ sig_ty
+                  ForeignImport
+  | ForeignExport (Located name) -- uses this name
+                  (LHsType name) -- sig_ty
+                  Coercion       -- sig_ty ~ rep_ty
+                  ForeignExport
   deriving (Data, Typeable)
+{-
+    In both ForeignImport and ForeignExport:
+        sig_ty is the type given in the Haskell code
+        rep_ty is the representation for this type, i.e. with newtypes
+               coerced away and type functions evaluated.
+    Thus if the declaration is valid, then rep_ty will only use types
+    such as Int and IO that we know how to make foreign calls with.
+-}
+
+noForeignImportCoercionYet :: Coercion
+noForeignImportCoercionYet
+    = panic "ForeignImport coercion evaluated before typechecking"
+
+noForeignExportCoercionYet :: Coercion
+noForeignExportCoercionYet
+    = panic "ForeignExport coercion evaluated before typechecking"
 
 -- Specification Of an imported external entity in dependence on the calling
 -- convention 
@@ -956,10 +980,10 @@ data ForeignExport = CExport  CExportSpec    -- contains the calling convention
 --
 
 instance OutputableBndr name => Outputable (ForeignDecl name) where
-  ppr (ForeignImport n ty fimport) =
+  ppr (ForeignImport n ty _ fimport) =
     hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
        2 (dcolon <+> ppr ty)
-  ppr (ForeignExport n ty fexport) =
+  ppr (ForeignExport n ty _ fexport) =
     hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
        2 (dcolon <+> ppr ty)
 

compiler/hsSyn/HsUtils.lhs

@@ -610,7 +610,7 @@ hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 
 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
 hsForeignDeclsBinders foreign_decls
-  = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
+  = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
 
 hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
 hsTyClDeclsBinders tycl_decls inst_decls

compiler/parser/RdrHsSyn.lhs

@@ -920,12 +920,12 @@ mkImport cconv safety (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
   let funcTarget = CFunction (StaticTarget entity Nothing)
       importSpec = CImport PrimCallConv safety nilFS funcTarget
-  return (ForD (ForeignImport v ty importSpec))
+  return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
 
   | otherwise = do
     case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
       Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
-      Just importSpec -> return (ForD (ForeignImport v ty importSpec))
+      Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
 
 -- the string "foo" is ambigous: either a header or a C identifier.  The
 -- C identifier case comes first in the alternatives below, so we pick
@@ -970,7 +970,7 @@ mkExport :: CCallConv
          -> (Located FastString, Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
 mkExport cconv (L _ entity, v, ty) = return $
-  ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
+  ForD (ForeignExport v ty noForeignExportCoercionYet (CExport (CExportStatic entity' cconv)))
   where
     entity' | nullFS entity = mkExtName (unLoc v)
             | otherwise     = entity

compiler/rename/RnNames.lhs

@@ -521,7 +521,7 @@ getLocalNonValBinders fixity_env
         ; return (envs, new_bndrs) } }
   where
     for_hs_bndrs :: [Located RdrName]
-    for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls]
+    for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls]
 
     -- In a hs-boot file, the value binders come from the
     --  *signatures*, and there should be no foreign binders

compiler/rename/RnSource.lhs

@@ -363,7 +363,7 @@ rnDefaultDecl (DefaultDecl tys)
 
 \begin{code}
 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
-rnHsForeignDecl (ForeignImport name ty spec)
+rnHsForeignDecl (ForeignImport name ty _ spec)
   = do { topEnv :: HscEnv <- getTopEnv
        ; name' <- lookupLocatedTopBndrRn name
        ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty
@@ -372,12 +372,12 @@ rnHsForeignDecl (ForeignImport name ty spec)
        ; let packageId = thisPackage $ hsc_dflags topEnv
 	     spec'     = patchForeignImport packageId spec
 
-       ; return (ForeignImport name' ty' spec', fvs) }
+       ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
 
-rnHsForeignDecl (ForeignExport name ty spec)
+rnHsForeignDecl (ForeignExport name ty _ spec)
   = do { name' <- lookupLocatedOccRn name
        ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty
-       ; return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name') }
+       ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
 	-- NB: a foreign export is an *occurrence site* for name, so 
 	--     we add it to the free-variable list.  It might, for example,
 	--     be imported from another module

compiler/typecheck/TcForeign.lhs

@@ -27,6 +27,10 @@ import TcHsType
 import TcExpr
 import TcEnv
 
+import FamInst
+import FamInstEnv
+import Type
+import TypeRep
 import ForeignCall
 import ErrUtils
 import Id
@@ -48,13 +52,94 @@ import Util
 \begin{code}
 -- Defines a binding
 isForeignImport :: LForeignDecl name -> Bool
-isForeignImport (L _ (ForeignImport _ _ _)) = True
-isForeignImport _                           = False
+isForeignImport (L _ (ForeignImport _ _ _ _)) = True
+isForeignImport _                             = False
 
 -- Exports a binding
 isForeignExport :: LForeignDecl name -> Bool
-isForeignExport (L _ (ForeignExport _ _ _)) = True
-isForeignExport _                           = False
+isForeignExport (L _ (ForeignExport _ _ _ _)) = True
+isForeignExport _                             = False
+\end{code}
+
+\begin{code}
+-- normaliseFfiType takes the type from an FFI declaration, and
+-- evaluates any type synonyms, type functions, and newtypes. However,
+-- we are only allowed to look through newtypes if the constructor is
+-- in scope.
+normaliseFfiType :: Type -> TcM (Coercion, Type)
+normaliseFfiType ty
+    = do fam_envs <- tcGetFamInstEnvs
+         normaliseFfiType' fam_envs ty
+
+normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type)
+normaliseFfiType' env ty0 = go [] ty0
+  where
+    go :: [TyCon] -> Type -> TcM (Coercion, Type)
+    go rec_nts ty | Just ty' <- coreView ty     -- Expand synonyms
+        = go rec_nts ty'
+
+    go rec_nts ty@(TyConApp tc tys)
+        -- We don't want to look through the IO newtype, even if it is
+        -- in scope, so we have a special case for it:
+        | tc `hasKey` ioTyConKey
+        = children_only
+        | isNewTyCon tc         -- Expand newtypes
+        -- We can't just use isRecursiveTyCon here, as we need to allow
+        -- some recursive types as described below
+        = if tc `elem` rec_nts  -- See Note [Expanding newtypes] in Type.lhs
+          then -- If this is a recursive newtype then it will normally
+               -- be rejected later as not being a valid FFI type.
+               -- Sometimes recursion is OK though, e.g. with
+               --     newtype T = T (Ptr T)
+               -- we don't reject the type for being recursive.
+               return (Refl ty, ty)
+          else do newtypeOK <- do env <- getGblEnv
+                                  case tyConSingleDataCon_maybe tc of
+                                      Just dataCon ->
+                                          return $ notNull $ lookupGRE_Name (tcg_rdr_env env) $ dataConName dataCon
+                                      _ ->
+                                          return False
+                  let newtypeForeign = nameModule_maybe (tyConName tc) `elem`
+                                       [Just (mkBaseModule (fsLit "Foreign.C.Types")),
+                                        Just (mkBaseModule (fsLit "System.Posix.Types"))]
+                  if newtypeOK || newtypeForeign
+                      then do let nt_co = mkAxInstCo (newTyConCo tc) tys
+                              add_co nt_co rec_nts' nt_rhs
+                      else children_only
+        | isFamilyTyCon tc              -- Expand open tycons
+        , (co, ty) <- normaliseTcApp env tc tys
+        , not (isReflCo co)
+        = add_co co rec_nts ty
+        | otherwise
+        = children_only
+        where
+          children_only = do xs <- mapM (go rec_nts) tys
+                             let (cos, tys') = unzip xs
+                             return (mkTyConAppCo tc cos, mkTyConApp tc tys')
+          nt_rhs = newTyConInstRhs tc tys
+          rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+                   | otherwise           = rec_nts
+
+    go rec_nts (AppTy ty1 ty2)
+      = do (coi1, nty1) <- go rec_nts ty1
+           (coi2, nty2) <- go rec_nts ty2
+           return (mkAppCo coi1 coi2, mkAppTy nty1 nty2)
+
+    go rec_nts (FunTy ty1 ty2)
+      = do (coi1,nty1) <- go rec_nts ty1
+           (coi2,nty2) <- go rec_nts ty2
+           return (mkFunCo coi1 coi2, mkFunTy nty1 nty2)
+
+    go rec_nts (ForAllTy tyvar ty1)
+      = do (coi,nty1) <- go rec_nts ty1
+           return (mkForAllCo tyvar coi, ForAllTy tyvar nty1)
+
+    go _ ty@(TyVarTy _)
+      = return (Refl ty, ty)
+
+    add_co co rec_nts ty
+        = do (co', ty') <- go rec_nts ty
+             return (mkTransCo co co', ty')
 \end{code}
 
 %************************************************************************
@@ -69,13 +154,14 @@ tcForeignImports decls
   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
 
 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
-tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
+tcFImport fo@(ForeignImport (L loc nm) hs_ty _ imp_decl)
   = addErrCtxt (foreignDeclCtxt fo)  $
     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+       ; (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty
        ; let
            -- Drop the foralls before inspecting the
            -- structure of the foreign type.
-             (_, t_ty)         = tcSplitForAllTys sig_ty
+             (_, t_ty)         = tcSplitForAllTys norm_sig_ty
              (arg_tys, res_ty) = tcSplitFunTys t_ty
              id                = mkLocalId nm sig_ty
                  -- Use a LocalId to obey the invariant that locally-defined
@@ -85,7 +171,7 @@ tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
        ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
           -- Can't use sig_ty here because sig_ty :: Type and
           -- we need HsType Id hence the undefined
-       ; return (id, ForeignImport (L loc id) undefined imp_decl') }
+       ; return (id, ForeignImport (L loc id) undefined (mkSymCo norm_co) imp_decl') }
 tcFImport d = pprPanic "tcFImport" (ppr d)
 \end{code}
 
@@ -198,13 +284,15 @@ tcForeignExports decls
        return (b `consBag` binds, f:fs)
 
 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
+tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec)
   = addErrCtxt (foreignDeclCtxt fo) $ do
 
     sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
     rhs <- tcPolyExpr (nlHsVar nm) sig_ty
 
-    tcCheckFEType sig_ty spec
+    (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty
+
+    tcCheckFEType norm_sig_ty spec
 
            -- we're exporting a function, but at a type possibly more
            -- constrained than its declared/inferred type. Hence the need
@@ -216,7 +304,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
     -- is *stable* (i.e. the compiler won't change it later),
     -- because this name will be referred to by the C code stub.
     id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
-    return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
+    return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec)
 tcFExport d = pprPanic "tcFExport" (ppr d)
 \end{code}
 
@@ -264,49 +352,15 @@ nonIOok  = True
 mustBeIO = False
 
 checkForeignRes non_io_result_ok safehs_check pred_res_ty ty
-        -- (IO t) is ok, and so is any newtype wrapping thereof
-  = do m <- tcSplitVisibleIOType_maybe ty
-       case m of
-           Just (_, res_ty, _)
-            | pred_res_ty res_ty ->
-               return ()
-           _ ->
-               check (non_io_result_ok && pred_res_ty ty)
-                     (illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
-
--- This is mostly a copy of TcType.tcSplitIOType_maybe, except it checks
--- that it doesn't look through any newtypes for which the constructor
--- is not exported.
-tcSplitVisibleIOType_maybe :: Type -> TcM (Maybe (TyCon, Type, Coercion))
-tcSplitVisibleIOType_maybe ty
-  = case tcSplitTyConApp_maybe ty of
-        -- This split absolutely has to be a tcSplit, because we must
-        -- see the IO type; and it's a newtype which is transparent to
-        -- splitTyConApp.
-
-        Just (io_tycon, [io_res_ty])
-           |  io_tycon `hasKey` ioTyConKey
-           -> return $ Just (io_tycon, io_res_ty, mkReflCo ty)
-
-        Just (tc, tys)
-           | not (isRecursiveTyCon tc)
-           , Just (ty, co1) <- instNewTyCon_maybe tc tys
-                  -- Newtypes that require a coercion are ok
-           -> do newtypeOK <- do env <- getGblEnv
-                                 case tyConSingleDataCon_maybe tc of
-                                     Just dataCon ->
-                                         return $ notNull $ lookupGRE_Name (tcg_rdr_env env) $ dataConName dataCon
-                                     Nothing ->
-                                         return False
-                 if newtypeOK
-                     then do m <- tcSplitVisibleIOType_maybe ty
-                             return $ case m of
-                                      Nothing             -> Nothing
-                                      Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
-                     else return Nothing
-
-        _ -> return Nothing
-
+    -- We need an (IO t) result. Any newtype wrappers of type functions
+    -- have already been dealt with by normaliseFfiType.
+  = case tcSplitIOType_maybe ty of
+    Just (_, res_ty)
+     | pred_res_ty res_ty ->
+        return ()
+    _ ->
+        check (non_io_result_ok && pred_res_ty ty)
+              (illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
 \end{code}
 
 \begin{code}

compiler/typecheck/TcHsSyn.lhs

@@ -964,8 +964,8 @@ zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
 
 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
-zonkForeignExport env (ForeignExport i _hs_ty spec) =
-   returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
+zonkForeignExport env (ForeignExport i _hs_ty co spec) =
+   returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec)
 zonkForeignExport _ for_imp 
   = returnM for_imp	-- Foreign imports don't need zonking
 \end{code}

compiler/typecheck/TcType.lhs

@@ -1230,28 +1230,17 @@ restricted set of types as arguments and results (the restricting factor
 being the )
 
 \begin{code}
-tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion)
--- (isIOType t) returns Just (IO,t',co)
---				if co : t ~ IO t'
---		returns Nothing otherwise
-tcSplitIOType_maybe ty 
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
+-- (tcSplitIOType_maybe t) returns Just (IO,t',co)
+--              if co : t ~ IO t'
+--              returns Nothing otherwise