projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Egregious bug in tcLHsConResTy
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcForeign.lhs
diff --git
a/compiler/typecheck/TcForeign.lhs
b/compiler/typecheck/TcForeign.lhs
index
4be039b
..
fa91028
100644
(file)
--- a/
compiler/typecheck/TcForeign.lhs
+++ b/
compiler/typecheck/TcForeign.lhs
@@
-35,7
+35,7
@@
import SMRep ( argMachRep, primRepToCgRep, primRepHint )
import OccName ( mkForeignExportOcc )
import Name ( Name, NamedThing(..), mkExternalName )
import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
import OccName ( mkForeignExportOcc )
import Name ( Name, NamedThing(..), mkExternalName )
import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
- tcSplitForAllTys,
+ tcSplitForAllTys, tcSplitIOType_maybe,
isFFIArgumentTy, isFFIImportResultTy,
isFFIExportResultTy, isFFILabelTy,
isFFIExternalTy, isFFIDynArgumentTy,
isFFIArgumentTy, isFFIImportResultTy,
isFFIExportResultTy, isFFILabelTy,
isFFIExternalTy, isFFIDynArgumentTy,
@@
-59,12
+59,12
@@
import MachOp ( machRepByteWidth, MachHint(FloatHint) )
\begin{code}
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
\begin{code}
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
-isForeignImport (L _ (ForeignImport _ _ _ _)) = True
+isForeignImport (L _ (ForeignImport _ _ _)) = True
isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
-isForeignExport (L _ (ForeignExport _ _ _ _)) = True
+isForeignExport (L _ (ForeignExport _ _ _)) = True
isForeignExport _ = False
\end{code}
isForeignExport _ = False
\end{code}
@@
-80,7
+80,7
@@
tcForeignImports decls
= mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
= mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
-tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
+tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
= addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
let
= addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
let
@@
-96,7
+96,7
@@
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
-- can't use sig_ty here because it :: Type and we need HsType Id
-- hence the undefined
tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
-- can't use sig_ty here because it :: Type and we need HsType Id
-- hence the undefined
- returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec)
+ returnM (id, ForeignImport (L loc id) undefined imp_decl')
\end{code}
\end{code}
@@
-212,7
+212,7
@@
tcForeignExports decls
returnM (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
returnM (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
@@
-233,7
+233,7
@@
tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
id = mkExportedLocalId gnm sig_ty
bind = L loc (VarBind id rhs)
in
id = mkExportedLocalId gnm sig_ty
bind = L loc (VarBind id rhs)
in
- returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)
+ returnM (bind, ForeignExport (L loc id) undefined spec)
\end{code}
------------ Checking argument types for foreign export ----------------------
\end{code}
------------ Checking argument types for foreign export ----------------------
@@
-277,13
+277,14
@@
nonIOok = True
mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
- = case tcSplitTyConApp_maybe ty of
- Just (io, [res_ty])
- | io `hasKey` ioTyConKey && pred_res_ty res_ty
- -> returnM ()
- _
- -> check (non_io_result_ok && pred_res_ty ty)
- (illegalForeignTyErr result ty)
+ -- (IO t) is ok, and so is any newtype wrapping thereof
+ | Just (io, res_ty) <- tcSplitIOType_maybe ty,
+ pred_res_ty res_ty
+ = returnM ()
+
+ | otherwise
+ = check (non_io_result_ok && pred_res_ty ty)
+ (illegalForeignTyErr result ty)
\end{code}
\begin{code}
\end{code}
\begin{code}