{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.Tc.Gen.Foreign
( tcForeignImports
, tcForeignExports
, isForeignImport, isForeignExport
, tcFImport, tcFExport
, tcForeignImports'
, tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
, normaliseFfiType
, nonIOok, mustBeIO
, checkSafe, noCheckSafe
, tcForeignExports'
, tcCheckFEType
) where
import GHC.Prelude
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Expr
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.ForeignCall
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim( isArrowTyCon )
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Utils.Error
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Data.Bag
import GHC.Driver.Hooks
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad ( zipWithM )
import Control.Monad.Trans.Writer.CPS
( WriterT, runWriterT, tell )
import Control.Monad.Trans.Class
( lift )
isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport (forall p a. UnXRec p => XRec p a -> a
unXRec @name -> ForeignImport {}) = Bool
True
isForeignImport LForeignDecl name
_ = Bool
False
isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport (forall p a. UnXRec p => XRec p a -> a
unXRec @name -> ForeignExport {}) = Bool
True
isForeignExport LForeignDecl name
_ = Bool
False
normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType Type
ty
= do FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
fam_envs Type
ty
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
env Type
ty0 = forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
Representational RecTcChecker
initRecTc Type
ty0
where
go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction
go :: Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
= Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
ty'
| Just (TyCon
tc, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
= Role
-> RecTcChecker
-> TyCon
-> [Type]
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go_tc_app Role
role RecTcChecker
rec_nts TyCon
tc [Type]
tys
| ([ForAllTyBinder]
bndrs, Type
inner_ty) <- Type -> ([ForAllTyBinder], Type)
splitForAllForAllTyBinders Type
ty
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ForAllTyBinder]
bndrs)
= do Reduction
redn <- Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
inner_ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ForAllTyBinder] -> Reduction -> Reduction
mkHomoForAllRedn [ForAllTyBinder]
bndrs Reduction
redn
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Role -> Type -> Reduction
mkReflRedn Role
role Type
ty
go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
-> WriterT (Bag GlobalRdrElt) TcM Reduction
go_tc_app :: Role
-> RecTcChecker
-> TyCon
-> [Type]
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go_tc_app Role
role RecTcChecker
rec_nts TyCon
tc [Type]
tys
| TyCon -> Bool
isArrowTyCon TyCon
tc
= WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
children_only
| Unique
tc_key forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ioTyConKey, Unique
funPtrTyConKey]
= WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
children_only
| TyCon -> Bool
isNewTyCon TyCon
tc
, Just RecTcChecker
rec_nts' <- RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_nts TyCon
tc
= do { GlobalRdrEnv
rdr_env <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ TcRn GlobalRdrEnv
getGlobalRdrEnv
; case GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI GlobalRdrEnv
rdr_env TyCon
tc of
Maybe GlobalRdrElt
Nothing -> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
nothing
Just GlobalRdrElt
gre ->
do { Reduction
redn <- Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts' Type
nt_rhs
; forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (forall a. a -> Bag a
unitBag GlobalRdrElt
gre)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Coercion
nt_co Coercion -> Reduction -> Reduction
`mkTransRedn` Reduction
redn } }
| TyCon -> Bool
isFamilyTyCon TyCon
tc
, Reduction Coercion
co Type
ty <- FamInstEnvs -> Role -> TyCon -> [Type] -> Reduction
normaliseTcApp FamInstEnvs
env Role
role TyCon
tc [Type]
tys
, Bool -> Bool
not (Coercion -> Bool
isReflexiveCo Coercion
co)
= do Reduction
redn <- Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Coercion
co Coercion -> Reduction -> Reduction
`mkTransRedn` Reduction
redn
| Bool
otherwise
= WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
nothing
where
tc_key :: Unique
tc_key = forall a. Uniquable a => a -> Unique
getUnique TyCon
tc
children_only :: WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
children_only
= do { Reductions
args <- [Reduction] -> Reductions
unzipRedns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ( \ Type
ty Role
r -> Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
r RecTcChecker
rec_nts Type
ty )
[Type]
tys (Role -> TyCon -> [Role]
tyConRoleListX Role
role TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Role -> TyCon -> Reductions -> Reduction
mkTyConAppRedn Role
role TyCon
tc Reductions
args }
nt_co :: Coercion
nt_co = Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
role (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
tc) [Type]
tys []
nt_rhs :: Type
nt_rhs = TyCon -> [Type] -> Type
newTyConInstRhs TyCon
tc [Type]
tys
ty :: Type
ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys
nothing :: WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Role -> Type -> Reduction
mkReflRedn Role
role Type
ty
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI GlobalRdrEnv
rdr_env TyCon
tc
| Just DataCon
con <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
, Just GlobalRdrElt
gre <- GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env (DataCon -> Name
dataConName DataCon
con)
= forall a. a -> Maybe a
Just GlobalRdrElt
gre
| Bool
otherwise
= forall a. Maybe a
Nothing
tcForeignImports :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports [LForeignDecl GhcRn]
decls = do
Hooks
hooks <- forall (m :: * -> *). HasHooks m => m Hooks
getHooks
case Hooks
-> Maybe
([LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignImportsHook Hooks
hooks of
Maybe
([LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
Nothing -> [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' [LForeignDecl GhcRn]
decls
Just [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
h -> [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
h [LForeignDecl GhcRn]
decls
tcForeignImports' :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' [LForeignDecl GhcRn]
decls
= do { ([Id]
ids, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
decls, [Bag GlobalRdrElt]
gres) <- forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M LForeignDecl GhcRn
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport [LForeignDecl GhcRn]
decls
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
decls, forall a. [Bag a] -> Bag a
unionManyBags [Bag GlobalRdrElt]
gres) }
tcFImport :: LForeignDecl GhcRn
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport :: LForeignDecl GhcRn
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport (L SrcSpanAnnA
dloc fo :: ForeignDecl GhcRn
fo@(ForeignImport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = L SrcSpanAnnN
nloc Name
nm, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
hs_ty
, fd_fi :: forall pass. ForeignDecl pass -> ForeignImport pass
fd_fi = ForeignImport GhcRn
imp_decl }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
dloc forall a b. (a -> b) -> a -> b
$ forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo) forall a b. (a -> b) -> a -> b
$
do { Type
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> UserTypeCtxt
ForSigCtxt Name
nm) LHsSigType GhcRn
hs_ty
; (Reduction Coercion
norm_co Type
norm_sig_ty, Bag GlobalRdrElt
gres) <- Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType Type
sig_ty
; let
([Scaled Type]
arg_tys, Type
res_ty) = Type -> ([Scaled Type], Type)
splitFunTys (Type -> Type
dropForAlls Type
norm_sig_ty)
id :: Id
id = HasDebugCallStack => Name -> Type -> Type -> Id
mkLocalId Name
nm Type
ManyTy Type
sig_ty
; ForeignImport GhcTc
imp_decl' <- [Scaled Type]
-> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty ForeignImport GhcRn
imp_decl
; let fi_decl :: ForeignDecl GhcTc
fi_decl = ForeignImport { fd_name :: LIdP GhcTc
fd_name = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nloc Id
id
, fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = forall a. HasCallStack => a
undefined
, fd_i_ext :: XForeignImport GhcTc
fd_i_ext = Coercion -> Coercion
mkSymCo Coercion
norm_co
, fd_fi :: ForeignImport GhcTc
fd_fi = ForeignImport GhcTc
imp_decl' }
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
id, forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
dloc ForeignDecl GhcTc
fi_decl, Bag GlobalRdrElt
gres) }
tcFImport LForeignDecl GhcRn
d = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFImport" (forall a. Outputable a => a -> SDoc
ppr LForeignDecl GhcRn
d)
tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc)
tcCheckFIType :: [Scaled Type]
-> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport GhcRn
idecl@(CImport XCImport GhcRn
src (L SrcSpan
lc CCallConv
cconv) XRec GhcRn Safety
safety Maybe Header
mh l :: CImportSpec
l@(CLabel CLabelString
_))
= do Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check (Type -> Validity' IllegalForeignTypeReason
isFFILabelTy (HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
res_ty))
(Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType forall a. Maybe a
Nothing)
CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
src (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') XRec GhcRn Safety
safety Maybe Header
mh CImportSpec
l)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport GhcRn
idecl@(CImport XCImport GhcRn
src (L SrcSpan
lc CCallConv
cconv) XRec GhcRn Safety
safety Maybe Header
mh CImportSpec
CWrapper) = do
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
case [Scaled Type]
arg_tys of
[Scaled Type
arg1_mult Type
arg1_ty] -> do
Type -> TcM ()
checkNoLinearFFI Type
arg1_mult
(Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy [Scaled Type]
arg1_tys
Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy Type
res1_ty
Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
mustBeIO Bool
checkSafe (Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy Type
arg1_ty) Type
res_ty
where
([Scaled Type]
arg1_tys, Type
res1_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
arg1_ty
[Scaled Type]
_ -> TcRnMessage -> TcM ()
addErrTc (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType forall a. Maybe a
Nothing IllegalForeignTypeReason
OneArgExpected)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
src (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') XRec GhcRn Safety
safety Maybe Header
mh CImportSpec
CWrapper)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport GhcRn
idecl@(CImport XCImport GhcRn
src (L SrcSpan
lc CCallConv
cconv) (L SrcSpan
ls Safety
safety) Maybe Header
mh
(CFunction CCallTarget
target))
| CCallTarget -> Bool
isDynamicTarget CCallTarget
target = do
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
case [Scaled Type]
arg_tys of
[] ->
TcRnMessage -> TcM ()
addErrTc (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType forall a. Maybe a
Nothing IllegalForeignTypeReason
AtLeastOneArgExpected)
(Scaled Type
arg1_mult Type
arg1_ty:[Scaled Type]
arg_tys) -> do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let curried_res_ty :: Type
curried_res_ty = HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
res_ty
Type -> TcM ()
checkNoLinearFFI Type
arg1_mult
Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check (Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy Type
curried_res_ty Type
arg1_ty)
(Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (forall a. a -> Maybe a
Just ArgOrResult
Arg))
(Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy DynFlags
dflags Safety
safety) [Scaled Type]
arg_tys
Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy DynFlags
dflags) Type
res_ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
src (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target)
| CCallConv
cconv forall a. Eq a => a -> a -> Bool
== CCallConv
PrimCallConv = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> TcRnMessage -> TcM ()
checkTc (Extension -> DynFlags -> Bool
xopt Extension
LangExt.GHCForeignImportPrim DynFlags
dflags)
(ForeignImport GhcRn -> TcRnMessage
TcRnForeignImportPrimExtNotSet ForeignImport GhcRn
idecl)
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
ForeignImport GhcRn -> CCallTarget -> TcM ()
checkCTarget ForeignImport GhcRn
idecl CCallTarget
target
Bool -> TcRnMessage -> TcM ()
checkTc (Safety -> Bool
playSafe Safety
safety)
(ForeignImport GhcRn -> TcRnMessage
TcRnForeignImportPrimSafeAnn ForeignImport GhcRn
idecl)
(Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimArgumentTy DynFlags
dflags) [Scaled Type]
arg_tys
Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimResultTy DynFlags
dflags) Type
res_ty
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
src (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv) (forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target))
| CCallConv
cconv forall a. Eq a => a -> a -> Bool
== CCallConv
JavaScriptCallConv = do
CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
src (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target))
| Bool
otherwise = do
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
ForeignImport GhcRn -> CCallTarget -> TcM ()
checkCTarget ForeignImport GhcRn
idecl CCallTarget
target
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy DynFlags
dflags Safety
safety) [Scaled Type]
arg_tys
Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy DynFlags
dflags) Type
res_ty
ForeignImport GhcRn -> [Type] -> Type -> TcM ()
checkMissingAmpersand ForeignImport GhcRn
idecl (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) Type
res_ty
case CCallTarget
target of
StaticTarget SourceText
_ CLabelString
_ Maybe Unit
_ Bool
False
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
arg_tys) ->
TcRnMessage -> TcM ()
addErrTc (ForeignImport GhcRn -> TcRnMessage
TcRnForeignFunctionImportAsValue ForeignImport GhcRn
idecl)
CCallTarget
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
src (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target)
checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM ()
checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM ()
checkCTarget ForeignImport GhcRn
idecl (StaticTarget SourceText
_ CLabelString
str Maybe Unit
_ Bool
_) = do
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
Bool -> TcRnMessage -> TcM ()
checkTc (CLabelString -> Bool
isCLabelString CLabelString
str) (CLabelString -> TcRnMessage
TcRnInvalidCIdentifier CLabelString
str)
checkCTarget ForeignImport GhcRn
_ CCallTarget
DynamicTarget = forall a. HasCallStack => String -> a
panic String
"checkCTarget DynamicTarget"
checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM ()
checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM ()
checkMissingAmpersand ForeignImport GhcRn
idecl [Type]
arg_tys Type
res_ty
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
arg_tys Bool -> Bool -> Bool
&& Type -> Bool
isFunPtrTy Type
res_ty
= TcRnMessage -> TcM ()
addDiagnosticTc forall a b. (a -> b) -> a -> b
$ ForeignImport GhcRn -> TcRnMessage
TcRnFunPtrImportWithoutAmpersand ForeignImport GhcRn
idecl
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
tcForeignExports :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports [LForeignDecl GhcRn]
decls = do
Hooks
hooks <- forall (m :: * -> *). HasHooks m => m Hooks
getHooks
case Hooks
-> Maybe
([LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignExportsHook Hooks
hooks of
Maybe
([LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
Nothing -> [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' [LForeignDecl GhcRn]
decls
Just [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
h -> [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
h [LForeignDecl GhcRn]
decls
tcForeignExports' :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' [LForeignDecl GhcRn]
decls
= forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall {ann}.
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
Bag GlobalRdrElt)
-> GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
Bag GlobalRdrElt)
combine (forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds, [], forall a. Bag a
emptyBag) (forall a. (a -> Bool) -> [a] -> [a]
filter forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport [LForeignDecl GhcRn]
decls)
where
combine :: (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
Bag GlobalRdrElt)
-> GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
Bag GlobalRdrElt)
combine (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds, [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)]
fs, Bag GlobalRdrElt
gres1) (L SrcSpanAnn' ann
loc ForeignDecl GhcRn
fe) = do
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b, ForeignDecl GhcTc
f, Bag GlobalRdrElt
gres2) <- forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
loc (ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport ForeignDecl GhcRn
fe)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b forall a. a -> Bag a -> Bag a
`consBag` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds, forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' ann
loc ForeignDecl GhcTc
f forall a. a -> [a] -> [a]
: [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)]
fs, Bag GlobalRdrElt
gres1 forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag GlobalRdrElt
gres2)
tcFExport :: ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport :: ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport fo :: ForeignDecl GhcRn
fo@(ForeignExport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = L SrcSpanAnnN
loc Name
nm, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
hs_ty, fd_fe :: forall pass. ForeignDecl pass -> ForeignExport pass
fd_fe = ForeignExport GhcRn
spec })
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo) forall a b. (a -> b) -> a -> b
$ do
Type
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> UserTypeCtxt
ForSigCtxt Name
nm) LHsSigType GhcRn
hs_ty
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Name
nm) Type
sig_ty
(Reduction Coercion
norm_co Type
norm_sig_ty, Bag GlobalRdrElt
gres) <- Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType Type
sig_ty
ForeignExport GhcTc
spec' <- Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
tcCheckFEType Type
norm_sig_ty ForeignExport GhcRn
spec
Id
id <- Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM Id
mkStableIdFromName Name
nm Type
sig_ty (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) OccName -> OccName
mkForeignExportOcc
forall (m :: * -> *) a. Monad m => a -> m a
return ( forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind Id
id GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
, ForeignExport { fd_name :: LIdP GhcTc
fd_name = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Id
id
, fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = forall a. HasCallStack => a
undefined
, fd_e_ext :: XForeignExport GhcTc
fd_e_ext = Coercion
norm_co
, fd_fe :: ForeignExport GhcTc
fd_fe = ForeignExport GhcTc
spec' }
, Bag GlobalRdrElt
gres)
tcFExport ForeignDecl GhcRn
d = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFExport" (forall a. Outputable a => a -> SDoc
ppr ForeignDecl GhcRn
d)
tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
tcCheckFEType Type
sig_ty edecl :: ForeignExport GhcRn
edecl@(CExport XCExport GhcRn
src (L SrcSpan
l (CExportStatic SourceText
esrc CLabelString
str CCallConv
cconv))) = do
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (forall a b. a -> Either a b
Left ForeignExport GhcRn
edecl) Backend -> Validity' ExpectedBackends
backendValidityOfCExport
Bool -> TcRnMessage -> TcM ()
checkTc (CLabelString -> Bool
isCLabelString CLabelString
str) (CLabelString -> TcRnMessage
TcRnInvalidCIdentifier CLabelString
str)
CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (forall a b. a -> Either a b
Left ForeignExport GhcRn
edecl) CCallConv
cconv
(Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy [Scaled Type]
arg_tys
Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
noCheckSafe Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy Type
res_ty
forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass.
XCExport pass -> XRec pass CExportSpec -> ForeignExport pass
CExport XCExport GhcRn
src (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (SourceText -> CLabelString -> CCallConv -> CExportSpec
CExportStatic SourceText
esrc CLabelString
str CCallConv
cconv')))
where
([Scaled Type]
arg_tys, Type
res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys (Type -> Type
dropForAlls Type
sig_ty)
checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM ()
checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity' IllegalForeignTypeReason
pred [Scaled Type]
tys = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Scaled Type -> TcM ()
go [Scaled Type]
tys
where
go :: Scaled Type -> TcM ()
go (Scaled Type
mult Type
ty) = Type -> TcM ()
checkNoLinearFFI Type
mult forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check (Type -> Validity' IllegalForeignTypeReason
pred Type
ty) (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (forall a. a -> Maybe a
Just ArgOrResult
Arg))
checkNoLinearFFI :: Mult -> TcM ()
checkNoLinearFFI :: Type -> TcM ()
checkNoLinearFFI Type
ManyTy = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNoLinearFFI Type
_ = TcRnMessage -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (forall a. a -> Maybe a
Just ArgOrResult
Arg)
IllegalForeignTypeReason
LinearTypesNotAllowed
checkForeignRes :: Bool -> Bool -> (Type -> Validity' IllegalForeignTypeReason) -> Type -> TcM ()
checkForeignRes :: Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
non_io_result_ok Bool
check_safe Type -> Validity' IllegalForeignTypeReason
pred_res_ty Type
ty
| Just (TyCon
_, Type
res_ty) <- Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
ty
=
Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check (Type -> Validity' IllegalForeignTypeReason
pred_res_ty Type
res_ty)
(Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (forall a. a -> Maybe a
Just ArgOrResult
Result))
| Type -> Bool
isForAllTy Type
ty
= TcRnMessage -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
UnexpectedNestedForall
| Bool -> Bool
not Bool
non_io_result_ok
= TcRnMessage -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
IOResultExpected
| Bool
otherwise
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case Type -> Validity' IllegalForeignTypeReason
pred_res_ty Type
ty of
NotValid IllegalForeignTypeReason
msg -> TcRnMessage -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
msg
Validity' IllegalForeignTypeReason
_ | Bool
check_safe Bool -> Bool -> Bool
&& DynFlags -> Bool
safeInferOn DynFlags
dflags
-> Messages TcRnMessage -> TcM ()
recordUnsafeInfer forall e. Messages e
emptyMessages
Validity' IllegalForeignTypeReason
_ | Bool
check_safe Bool -> Bool -> Bool
&& DynFlags -> Bool
safeLanguageOn DynFlags
dflags
-> TcRnMessage -> TcM ()
addErrTc (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
SafeHaskellMustBeInIO)
Validity' IllegalForeignTypeReason
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () }
nonIOok, mustBeIO :: Bool
nonIOok :: Bool
nonIOok = Bool
True
mustBeIO :: Bool
mustBeIO = Bool
False
checkSafe, noCheckSafe :: Bool
checkSafe :: Bool
checkSafe = Bool
True
noCheckSafe :: Bool
noCheckSafe = Bool
False
checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl Backend -> Validity' ExpectedBackends
check = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let bcknd :: Backend
bcknd = DynFlags -> Backend
backend DynFlags
dflags
case Backend -> Validity' ExpectedBackends
check Backend
bcknd of
Validity' ExpectedBackends
IsValid -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
NotValid ExpectedBackends
expectedBcknds ->
TcRnMessage -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> Backend -> ExpectedBackends -> TcRnMessage
TcRnIllegalForeignDeclBackend Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl Backend
bcknd ExpectedBackends
expectedBcknds
checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
_ CCallConv
CCallConv = forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
_ CCallConv
CApiConv = forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CApiConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl CCallConv
StdCallConv = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
if Platform -> Arch
platformArch Platform
platform forall a. Eq a => a -> a -> Bool
== Arch
ArchX86
then forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
StdCallConv
else do
let msg :: TcRnMessage
msg = Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> UnsupportedCallConvention -> TcRnMessage
TcRnUnsupportedCallConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl UnsupportedCallConvention
StdCallConvUnsupported
TcRnMessage -> TcM ()
addDiagnosticTc TcRnMessage
msg
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl CCallConv
PrimCallConv = do
TcRnMessage -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> UnsupportedCallConvention -> TcRnMessage
TcRnUnsupportedCallConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl UnsupportedCallConvention
PrimCallConvUnsupported
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
PrimCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl CCallConv
JavaScriptCallConv = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) forall a. Eq a => a -> a -> Bool
== Arch
ArchJavaScript
then forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
JavaScriptCallConv
else do
TcRnMessage -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> UnsupportedCallConvention -> TcRnMessage
TcRnUnsupportedCallConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl UnsupportedCallConvention
JavaScriptCallConvUnsupported
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
JavaScriptCallConv
check :: Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage)
-> TcM ()
check :: Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check Validity' IllegalForeignTypeReason
IsValid IllegalForeignTypeReason -> TcRnMessage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
check (NotValid IllegalForeignTypeReason
reason) IllegalForeignTypeReason -> TcRnMessage
mkMessage = TcRnMessage -> TcM ()
addErrTc (IllegalForeignTypeReason -> TcRnMessage
mkMessage IllegalForeignTypeReason
reason)
foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo
= SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"When checking declaration:")
Int
2 (forall a. Outputable a => a -> SDoc
ppr ForeignDecl GhcRn
fo)