Commit 66b047ee authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Towards fixing Trac #5664

This patch makes normaliseFFIType recurse ito the arguments of FunPtr
parent bb643386
...@@ -84,8 +84,9 @@ normaliseFfiType' env ty0 = go [] ty0 ...@@ -84,8 +84,9 @@ normaliseFfiType' env ty0 = go [] ty0
go rec_nts ty@(TyConApp tc tys) go rec_nts ty@(TyConApp tc tys)
-- We don't want to look through the IO newtype, even if it is -- We don't want to look through the IO newtype, even if it is
-- in scope, so we have a special case for it: -- in scope, so we have a special case for it:
| tc `hasKey` ioTyConKey | tc_key `elem` [ioTyConKey, funPtrTyConKey]
= children_only = children_only
| isNewTyCon tc -- Expand newtypes | isNewTyCon tc -- Expand newtypes
-- We can't just use isRecursiveTyCon here, as we need to allow -- We can't just use isRecursiveTyCon here, as we need to allow
-- some recursive types as described below -- some recursive types as described below
...@@ -143,7 +144,7 @@ normaliseFfiType' env ty0 = go [] ty0 ...@@ -143,7 +144,7 @@ normaliseFfiType' env ty0 = go [] ty0
-- because whether an FFI type is legal or not depends only on -- because whether an FFI type is legal or not depends only on
-- the top-level type constructor (e.g. "Ptr a" is valid for all a). -- the top-level type constructor (e.g. "Ptr a" is valid for all a).
where where
tc_key = getUnique tc
children_only = do xs <- mapM (go rec_nts) tys children_only = do xs <- mapM (go rec_nts) tys
let (cos, tys') = unzip xs let (cos, tys') = unzip xs
return (mkTyConAppCo tc cos, mkTyConApp tc tys') return (mkTyConAppCo tc cos, mkTyConApp tc tys')
...@@ -230,6 +231,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do ...@@ -230,6 +231,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do
[arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty
checkForeignRes mustBeIO checkSafe isFFIDynResultTy res_ty checkForeignRes mustBeIO checkSafe isFFIDynResultTy res_ty
-- ToDo: Why are res1_ty and res_ty not equal?
where where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
_ -> addErrTc (illegalForeignTyErr empty sig_ty) _ -> addErrTc (illegalForeignTyErr empty sig_ty)
......
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