{-# 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.Utils.Unique
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 )
import Data.Maybe (isJust)
import GHC.Builtin.Types (unitTyCon)
import GHC.Types.RepType (typePrimRep1)
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 fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
normaliseFfiType' fam_envs ty
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
env Type
ty0 = WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
-> TcM (Reduction, Bag GlobalRdrElt)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT (WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
-> TcM (Reduction, Bag GlobalRdrElt))
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
-> TcM (Reduction, Bag GlobalRdrElt)
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])
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 ([ForAllTyBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ForAllTyBinder]
bndrs)
= do redn <- Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
inner_ty
return $ mkHomoForAllRedn bndrs redn
| Bool
otherwise
= Reduction
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a.
a -> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduction
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> Reduction
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
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 Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 { rdr_env <- IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) GlobalRdrEnv
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT (Bag GlobalRdrElt) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) GlobalRdrEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
getGlobalRdrEnv
; case checkNewtypeFFI rdr_env tc of
Maybe GlobalRdrElt
Nothing -> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
nothing
Just GlobalRdrElt
gre ->
do { redn <- Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts' Type
nt_rhs
; tell (unitBag gre)
; return $ nt_co `mkTransRedn` 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 redn <- Role
-> RecTcChecker
-> Type
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
ty
return $ co `mkTransRedn` redn
| Bool
otherwise
= WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
nothing
where
tc_key :: Unique
tc_key = TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc
children_only :: WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
children_only
= do { args <- [Reduction] -> Reductions
unzipRedns ([Reduction] -> Reductions)
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) [Reduction]
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reductions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Type
-> Role
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> [Type]
-> [Role]
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) [Reduction]
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)
; return $ mkTyConAppRedn role tc 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 = Reduction
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a.
a -> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduction
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> Reduction
-> WriterT
(Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
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
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
rdr_env (DataCon -> Name
dataConName DataCon
con)
= GlobalRdrElt -> Maybe GlobalRdrElt
forall a. a -> Maybe a
Just GlobalRdrElt
gre
| Bool
otherwise
= Maybe GlobalRdrElt
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 <- IOEnv (Env TcGblEnv TcLclEnv) Hooks
forall (m :: * -> *). HasHooks m => m Hooks
getHooks
case tcForeignImportsHook 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 { (ids, decls, gres) <- (GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (ForeignDecl GhcTc), Bag GlobalRdrElt))
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([Id], [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)],
[Bag GlobalRdrElt])
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)
GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (ForeignDecl GhcTc), Bag GlobalRdrElt)
tcFImport ([GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([Id], [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)],
[Bag GlobalRdrElt]))
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([Id], [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)],
[Bag GlobalRdrElt])
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LForeignDecl GhcRn -> Bool
GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> Bool
forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport [LForeignDecl GhcRn]
[GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
decls
; return (ids, decls, unionManyBags 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 }))
= SrcSpanAnnA
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
dloc (TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt))
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$ SDoc
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo) (TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt))
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$
do { sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> UserTypeCtxt
ForSigCtxt Name
nm) LHsSigType GhcRn
hs_ty
; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
; let
(arg_tys, res_ty) = splitFunTys (dropForAlls norm_sig_ty)
id = HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
nm Type
ManyTy Type
sig_ty
; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
; let fi_decl = ForeignImport { fd_name :: LIdP GhcTc
fd_name = SrcSpanAnnN -> Id -> GenLocated SrcSpanAnnN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nloc Id
id
, fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = LHsSigType GhcTc
GenLocated SrcSpanAnnA (HsSigType GhcTc)
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' }
; return (id, L dloc fi_decl, gres) }
tcFImport LForeignDecl GhcRn
d = String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (ForeignDecl GhcTc), Bag GlobalRdrElt)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFImport" (GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LForeignDecl GhcRn
GenLocated SrcSpanAnnA (ForeignDecl 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 EpaLocation
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 (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
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 ([Scaled Type] -> Type -> Type
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
res_ty))
(Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType Maybe ArgOrResult
forall a. Maybe a
Nothing)
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
return (CImport src (L lc cconv') safety mh l)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport GhcRn
idecl@(CImport XCImport GhcRn
src (L EpaLocation
lc CCallConv
cconv) XRec GhcRn Safety
safety Maybe Header
mh CImportSpec
CWrapper) = do
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
case 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 Maybe ArgOrResult
forall a. Maybe a
Nothing IllegalForeignTypeReason
OneArgExpected)
return (CImport src (L lc cconv') safety mh CWrapper)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport GhcRn
idecl@(CImport XCImport GhcRn
src (L EpaLocation
lc CCallConv
cconv) (L EpaLocation
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 (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
case arg_tys of
[] ->
TcRnMessage -> TcM ()
addErrTc (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType Maybe ArgOrResult
forall a. Maybe a
Nothing IllegalForeignTypeReason
AtLeastOneArgExpected)
(Scaled Type
arg1_mult Type
arg1_ty:[Scaled Type]
arg_tys) -> do
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let curried_res_ty = [Scaled Type] -> Type -> Type
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
res_ty
checkNoLinearFFI arg1_mult
check (isFFIDynTy curried_res_ty arg1_ty)
(TcRnIllegalForeignType (Just Arg))
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target)
| CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
== CCallConv
PrimCallConv = do
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
checkTc (xopt LangExt.GHCForeignImportPrim dflags)
(TcRnForeignImportPrimExtNotSet idecl)
checkCg (Right idecl) backendValidityOfCImport
checkCTarget idecl target
checkTc (playSafe safety)
(TcRnForeignImportPrimSafeAnn idecl)
checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
return (CImport src (L lc cconv) (L ls safety) mh (CFunction target))
| CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
== CCallConv
JavaScriptCallConv = do
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
checkCg (Right idecl) backendValidityOfCImport
return (CImport src (L lc cconv') (L ls safety) mh (CFunction target))
| Bool
otherwise = do
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
checkCTarget idecl target
dflags <- getDynFlags
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
checkMissingAmpersand idecl target (map scaledThing arg_tys) res_ty
case target of
StaticTarget SourceText
_ CLabelString
_ Maybe Unit
_ Bool
False
| Bool -> Bool
not ([Scaled Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
arg_tys) ->
TcRnMessage -> TcM ()
addErrTc (ForeignImport GhcRn -> TcRnMessage
TcRnForeignFunctionImportAsValue ForeignImport GhcRn
idecl)
CCallTarget
_ -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
return $ CImport src (L lc cconv') (L ls safety) mh (CFunction 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 (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
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 = String -> TcM ()
forall a. HasCallStack => String -> a
panic String
"checkCTarget DynamicTarget"
checkMissingAmpersand :: ForeignImport GhcRn -> CCallTarget -> [Type] -> Type -> TcM ()
checkMissingAmpersand :: ForeignImport GhcRn -> CCallTarget -> [Type] -> Type -> TcM ()
checkMissingAmpersand ForeignImport GhcRn
_ (StaticTarget SourceText
_ CLabelString
_ Maybe Unit
_ Bool
False) [Type]
_ Type
_ = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkMissingAmpersand ForeignImport GhcRn
idecl CCallTarget
_ [Type]
arg_tys Type
res_ty
| [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
arg_tys Bool -> Bool -> Bool
&& Type -> Bool
isFunPtrTy Type
res_ty
= TcRnMessage -> TcM ()
addDiagnosticTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ ForeignImport GhcRn -> TcRnMessage
TcRnFunPtrImportWithoutAmpersand ForeignImport GhcRn
idecl
| Bool
otherwise
= () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 <- IOEnv (Env TcGblEnv TcLclEnv) Hooks
forall (m :: * -> *). HasHooks m => m Hooks
getHooks
case tcForeignExportsHook 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
= (([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
-> GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt))
-> ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
-> GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
forall {ann}.
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated (EpAnn ann) (ForeignDecl GhcTc)], Bag GlobalRdrElt)
-> GenLocated (EpAnn ann) (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated (EpAnn ann) (ForeignDecl GhcTc)], Bag GlobalRdrElt)
combine (LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds, [], Bag GlobalRdrElt
forall a. Bag a
emptyBag) ((GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LForeignDecl GhcRn -> Bool
GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> Bool
forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport [LForeignDecl GhcRn]
[GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
decls)
where
combine :: ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated (EpAnn ann) (ForeignDecl GhcTc)], Bag GlobalRdrElt)
-> GenLocated (EpAnn ann) (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[GenLocated (EpAnn ann) (ForeignDecl GhcTc)], Bag GlobalRdrElt)
combine ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds, [GenLocated (EpAnn ann) (ForeignDecl GhcTc)]
fs, Bag GlobalRdrElt
gres1) (L EpAnn ann
loc ForeignDecl GhcRn
fe) = do
(b, f, gres2) <- EpAnn ann
-> TcRn
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
Bag GlobalRdrElt)
-> TcRn
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
Bag GlobalRdrElt)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport ForeignDecl GhcRn
fe)
return (b : binds, L loc f : fs, gres1 `unionBags` 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 })
= SDoc
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo) (TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt))
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$ do
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> UserTypeCtxt
ForSigCtxt Name
nm) LHsSigType GhcRn
hs_ty
rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty
(Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
spec' <- tcCheckFEType norm_sig_ty spec
id <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc
return ( mkVarBind id rhs
, ForeignExport { fd_name = L loc id
, fd_sig_ty = undefined
, fd_e_ext = norm_co
, fd_fe = spec' }
, gres)
tcFExport ForeignDecl GhcRn
d = String
-> SDoc
-> TcRn
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
Bag GlobalRdrElt)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFExport" (ForeignDecl GhcRn -> SDoc
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 EpaLocation
l (CExportStatic SourceText
esrc CLabelString
str CCallConv
cconv))) = do
Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignExport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
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)
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignExport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. a -> Either a b
Left ForeignExport GhcRn
edecl) CCallConv
cconv
checkForeignArgs isFFIExternalTy arg_tys
checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
return (CExport src (L l (CExportStatic esrc str 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
mult Type
ty)]
| Type -> Bool
isUnboxedTupleType Type
ty
, PrimOrVoidRep
VoidRep <- HasDebugCallStack => Type -> PrimOrVoidRep
Type -> PrimOrVoidRep
typePrimRep1 Type
ty
= do
Type -> TcM ()
checkNoLinearFFI Type
mult
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case (validIfUnliftedFFITypes dflags) of
Validity' TypeCannotBeMarshaledReason
IsValid -> Type -> TcM ()
checkNoLinearFFI Type
mult
NotValid TypeCannotBeMarshaledReason
needs_uffi -> TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$
Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType
(ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Arg)
(Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty TypeCannotBeMarshaledReason
needs_uffi)
checkForeignArgs Type -> Validity' IllegalForeignTypeReason
pred [Scaled Type]
tys = (Scaled Type -> TcM ()) -> [Scaled Type] -> TcM ()
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 TcM () -> TcM () -> TcM ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
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 (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Arg))
checkNoLinearFFI :: Mult -> TcM ()
checkNoLinearFFI :: Type -> TcM ()
checkNoLinearFFI Type
ManyTy = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNoLinearFFI Type
_ = TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
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 (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result))
| Type -> Bool
isForAllTy Type
ty
= TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
UnexpectedNestedForall
| Bool -> Bool
not Bool
non_io_result_ok
= TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
IOResultExpected
| Bool
otherwise
= do { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case pred_res_ty ty of
NotValid IllegalForeignTypeReason
msg -> TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
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 Messages TcRnMessage
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 (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
SafeHaskellMustBeInIO)
Validity' IllegalForeignTypeReason
_ -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let bcknd = DynFlags -> Backend
backend DynFlags
dflags
case check bcknd of
Validity' ExpectedBackends
IsValid -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
NotValid ExpectedBackends
expectedBcknds ->
TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
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 = CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
_ CCallConv
CApiConv = CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CApiConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl CCallConv
StdCallConv = 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
CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl CCallConv
PrimCallConv = do
TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> UnsupportedCallConvention -> TcRnMessage
TcRnUnsupportedCallConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl UnsupportedCallConvention
PrimCallConvUnsupported
CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
PrimCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl CCallConv
JavaScriptCallConv = do
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if platformArch (targetPlatform dflags) `elem` [ ArchJavaScript, ArchWasm32 ]
then return JavaScriptCallConv
else do
addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported
return JavaScriptCallConv
check :: Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage)
-> TcM ()
check :: Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check Validity' IllegalForeignTypeReason
IsValid IllegalForeignTypeReason -> TcRnMessage
_ = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When checking declaration:")
Int
2 (ForeignDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignDecl GhcRn
fo)
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy DynFlags
dflags Safety
safety Type
ty
= (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags
-> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalOutgoingTyCon DynFlags
dflags Safety
safety) Type
ty
isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon Type
ty
isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy DynFlags
dflags Type
ty
= (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon DynFlags
dflags) Type
ty
isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon Type
ty
isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy Type
expected Type
ty
| Just (TyCon
tc, [Type
ty']) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, TyCon -> Unique
tyConUnique TyCon
tc Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ptrTyConKey, Unique
funPtrTyConKey]
, HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
eqType Type
ty' Type
expected
= Validity' IllegalForeignTypeReason
forall a. Validity' a
IsValid
| Bool
otherwise
= IllegalForeignTypeReason -> Validity' IllegalForeignTypeReason
forall a. a -> Validity' a
NotValid (Type -> Type -> IllegalForeignTypeReason
ForeignDynNotPtr Type
expected Type
ty)
isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason
isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason
isFFILabelTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
forall {a}.
Uniquable a =>
a -> Validity' TypeCannotBeMarshaledReason
ok Type
ty
where
ok :: a -> Validity' TypeCannotBeMarshaledReason
ok a
tc | a
tc a -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey Bool -> Bool -> Bool
|| a
tc a -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ptrTyConKey
= Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise
= TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
ForeignLabelNotAPtr
checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
| Just Type
ki <- Type -> Maybe Type
anyTy_maybe Type
ty
= Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason)
forall a. a -> Maybe a
Just (Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason))
-> Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason)
forall a b. (a -> b) -> a -> b
$
if Maybe Levity -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Levity -> Bool) -> Maybe Levity -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Levity
kindBoxedRepLevity_maybe Type
ki
then Validity' IllegalForeignTypeReason
forall a. Validity' a
IsValid
else IllegalForeignTypeReason -> Validity' IllegalForeignTypeReason
forall a. a -> Validity' a
NotValid (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty TypeCannotBeMarshaledReason
NotBoxedKindAny)
| Bool
otherwise
= Maybe (Validity' IllegalForeignTypeReason)
forall a. Maybe a
Nothing
isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimArgumentTy DynFlags
dflags Type
ty
| Just Validity' IllegalForeignTypeReason
validity <- Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
= Validity' IllegalForeignTypeReason
validity
| Bool
otherwise
= (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon DynFlags
dflags) Type
ty
isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimResultTy DynFlags
dflags Type
ty
| Just Validity' IllegalForeignTypeReason
validity <- Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
= Validity' IllegalForeignTypeReason
validity
| Bool
otherwise
= (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon DynFlags
dflags) Type
ty
isFunPtrTy :: Type -> Bool
isFunPtrTy :: Type -> Bool
isFunPtrTy Type
ty
| Just (TyCon
tc, [Type
_]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
= TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey
| Bool
otherwise
= Bool
False
checkRepTyCon
:: (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type
-> Validity' IllegalForeignTypeReason
checkRepTyCon :: (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
check_tc Type
ty
= (TypeCannotBeMarshaledReason -> IllegalForeignTypeReason)
-> Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason
forall a b. (a -> b) -> Validity' a -> Validity' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty) (Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason)
-> Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason
forall a b. (a -> b) -> a -> b
$ case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
Just (TyCon
tc, [Type]
tys)
| TyCon -> Bool
isNewTyCon TyCon
tc -> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid (TyCon -> [Type] -> TypeCannotBeMarshaledReason
mk_nt_reason TyCon
tc [Type]
tys)
| Bool
otherwise -> TyCon -> Validity' TypeCannotBeMarshaledReason
check_tc TyCon
tc
Maybe (TyCon, [Type])
Nothing -> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotADataType
where
mk_nt_reason :: TyCon -> [Type] -> TypeCannotBeMarshaledReason
mk_nt_reason TyCon
tc [Type]
tys = TyCon -> [Type] -> TypeCannotBeMarshaledReason
NewtypeDataConNotInScope TyCon
tc [Type]
tys
legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon TyCon
tc
= TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon DynFlags
dflags TyCon
tc
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise = DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc
legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon TyCon
tc
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise = TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalOutgoingTyCon :: DynFlags
-> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalOutgoingTyCon DynFlags
dflags Safety
_ TyCon
tc
= DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc
marshalablePrimTyCon :: TyCon -> Bool
marshalablePrimTyCon :: TyCon -> Bool
marshalablePrimTyCon TyCon
tc = TyCon -> Bool
isPrimTyCon TyCon
tc Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isLiftedTypeKind (TyCon -> Type
tyConResKind TyCon
tc))
marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc
| TyCon -> Bool
marshalablePrimTyCon TyCon
tc
= DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
| TyCon -> [Unique] -> Bool
forall a. Uniquable a => a -> [Unique] -> Bool
anyOfUnique TyCon
tc [ Unique
intTyConKey, Unique
int8TyConKey, Unique
int16TyConKey
, Unique
int32TyConKey, Unique
int64TyConKey
, Unique
wordTyConKey, Unique
word8TyConKey, Unique
word16TyConKey
, Unique
word32TyConKey, Unique
word64TyConKey
, Unique
floatTyConKey, Unique
doubleTyConKey
, Unique
ptrTyConKey, Unique
funPtrTyConKey
, Unique
charTyConKey
, Unique
stablePtrTyConKey
, Unique
boolTyConKey
, Unique
jsvalTyConKey
]
= Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotABoxedMarshalableTyCon
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon DynFlags
dflags TyCon
tc
| TyCon -> Bool
marshalablePrimTyCon TyCon
tc
= DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotSimpleUnliftedType
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon DynFlags
dflags TyCon
tc
| TyCon -> Bool
marshalablePrimTyCon TyCon
tc
= DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc
= DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid (TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason)
-> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a b. (a -> b) -> a -> b
$ TypeCannotBeMarshaledReason
NotSimpleUnliftedType
validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedFFITypes DynFlags
dflags = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
UnliftedFFITypesNeeded