{-# LANGUAGE ViewPatterns #-}
module Foreign.Hoppy.Generator.Spec.Function (
Function, fnT, fnT',
makeFn,
fnExtName,
fnCName,
fnPurity,
fnParams,
fnReturn,
fnReqs,
fnAddendum,
fnExceptionHandlers,
CallDirection (..),
CppCallType (..),
sayCppArgRead,
sayCppArgNames,
sayCppExportFn,
sayHsExportFn,
sayHsArgProcessing,
sayHsCallAndProcessReturn,
) where
import Control.Monad (forM_, unless, when)
import Control.Monad.Except (throwError)
import Data.Function (on)
import Data.List (intersperse)
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Foreign.Hoppy.Generator.Common (fromMaybeM)
import qualified Foreign.Hoppy.Generator.Language.Cpp as LC
import qualified Foreign.Hoppy.Generator.Language.Haskell as LH
import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Spec.Class as Class
import Foreign.Hoppy.Generator.Spec.Base
import Foreign.Hoppy.Generator.Types (constT, intT, objT, objToHeapT, ptrT, refT, voidT)
import Language.Haskell.Syntax (
HsContext,
HsName (HsIdent),
HsQName (UnQual),
HsQualType (HsQualType),
HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar),
)
data Function = Function
{ Function -> FnName Identifier
fnCName :: FnName Identifier
, Function -> ExtName
fnExtName :: ExtName
, Function -> Purity
fnPurity :: Purity
, Function -> [Parameter]
fnParams :: [Parameter]
, Function -> Type
fnReturn :: Type
, Function -> Reqs
fnReqs :: Reqs
, Function -> ExceptionHandlers
fnExceptionHandlers :: ExceptionHandlers
, Function -> Addendum
fnAddendum :: Addendum
}
instance Eq Function where
== :: Function -> Function -> Bool
(==) = ExtName -> ExtName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ExtName -> ExtName -> Bool)
-> (Function -> ExtName) -> Function -> Function -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Function -> ExtName
fnExtName
instance Show Function where
show :: Function -> String
show Function
fn =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"<Function ", ExtName -> String
forall a. Show a => a -> String
show (Function -> ExtName
fnExtName Function
fn), String
" ", FnName Identifier -> String
forall a. Show a => a -> String
show (Function -> FnName Identifier
fnCName Function
fn),
[Parameter] -> String
forall a. Show a => a -> String
show (Function -> [Parameter]
fnParams Function
fn), String
" ", Type -> String
forall a. Show a => a -> String
show (Function -> Type
fnReturn Function
fn), String
">"]
instance Exportable Function where
sayExportCpp :: SayExportMode -> Function -> Generator ()
sayExportCpp = SayExportMode -> Function -> Generator ()
sayCppExport
sayExportHaskell :: SayExportMode -> Function -> Generator ()
sayExportHaskell = SayExportMode -> Function -> Generator ()
sayHsExport
instance HasExtNames Function where
getPrimaryExtName :: Function -> ExtName
getPrimaryExtName = Function -> ExtName
fnExtName
instance HasReqs Function where
getReqs :: Function -> Reqs
getReqs = Function -> Reqs
fnReqs
setReqs :: Reqs -> Function -> Function
setReqs Reqs
reqs Function
fn = Function
fn { fnReqs :: Reqs
fnReqs = Reqs
reqs }
instance HasAddendum Function where
getAddendum :: Function -> Addendum
getAddendum = Function -> Addendum
fnAddendum
setAddendum :: Addendum -> Function -> Function
setAddendum Addendum
addendum Function
fn = Function
fn { fnAddendum :: Addendum
fnAddendum = Addendum
addendum }
instance HandlesExceptions Function where
getExceptionHandlers :: Function -> ExceptionHandlers
getExceptionHandlers = Function -> ExceptionHandlers
fnExceptionHandlers
modifyExceptionHandlers :: (ExceptionHandlers -> ExceptionHandlers) -> Function -> Function
modifyExceptionHandlers ExceptionHandlers -> ExceptionHandlers
f Function
fn = Function
fn { fnExceptionHandlers :: ExceptionHandlers
fnExceptionHandlers = ExceptionHandlers -> ExceptionHandlers
f (ExceptionHandlers -> ExceptionHandlers)
-> ExceptionHandlers -> ExceptionHandlers
forall a b. (a -> b) -> a -> b
$ Function -> ExceptionHandlers
fnExceptionHandlers Function
fn }
makeFn :: (IsFnName Identifier name, IsParameter p)
=> name
-> Maybe ExtName
-> Purity
-> [p]
-> Type
-> Function
makeFn :: name -> Maybe ExtName -> Purity -> [p] -> Type -> Function
makeFn name
cName Maybe ExtName
maybeExtName Purity
purity [p]
paramTypes Type
retType =
let fnName :: FnName Identifier
fnName = name -> FnName Identifier
forall t a. IsFnName t a => a -> FnName t
toFnName name
cName
in FnName Identifier
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> Reqs
-> ExceptionHandlers
-> Addendum
-> Function
Function FnName Identifier
fnName
(HasCallStack => FnName Identifier -> Maybe ExtName -> ExtName
FnName Identifier -> Maybe ExtName -> ExtName
extNameOrFnIdentifier FnName Identifier
fnName Maybe ExtName
maybeExtName)
Purity
purity ([p] -> [Parameter]
forall a. IsParameter a => [a] -> [Parameter]
toParameters [p]
paramTypes) Type
retType Reqs
forall a. Monoid a => a
mempty ExceptionHandlers
forall a. Monoid a => a
mempty Addendum
forall a. Monoid a => a
mempty
fnT :: [Type] -> Type -> Type
fnT :: [Type] -> Type -> Type
fnT = [Parameter] -> Type -> Type
Internal_TFn ([Parameter] -> Type -> Type)
-> ([Type] -> [Parameter]) -> [Type] -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Parameter) -> [Type] -> [Parameter]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Parameter
forall a. IsParameter a => a -> Parameter
toParameter
fnT' :: [Parameter] -> Type -> Type
fnT' :: [Parameter] -> Type -> Type
fnT' = [Parameter] -> Type -> Type
Internal_TFn
sayCppExport :: LC.SayExportMode -> Function -> LC.Generator ()
sayCppExport :: SayExportMode -> Function -> Generator ()
sayCppExport SayExportMode
mode Function
fn = case SayExportMode
mode of
SayExportMode
LC.SayHeader -> () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
SayExportMode
LC.SaySource -> do
Reqs -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Reqs -> m ()
LC.addReqsM (Reqs -> Generator ()) -> Reqs -> Generator ()
forall a b. (a -> b) -> a -> b
$ Function -> Reqs
fnReqs Function
fn
ExtName
-> CppCallType
-> Maybe Type
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Bool
-> Generator ()
sayCppExportFn (Function -> ExtName
fnExtName Function
fn)
(case Function -> FnName Identifier
fnCName Function
fn of
FnName Identifier
identifier -> Generator () -> CppCallType
CallFn (Generator () -> CppCallType) -> Generator () -> CppCallType
forall a b. (a -> b) -> a -> b
$ Identifier -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier Identifier
identifier
FnOp Operator
op -> Operator -> CppCallType
CallOp Operator
op)
Maybe Type
forall a. Maybe a
Nothing
(Function -> [Parameter]
fnParams Function
fn)
(Function -> Type
fnReturn Function
fn)
(Function -> ExceptionHandlers
fnExceptionHandlers Function
fn)
Bool
True
data CallDirection =
ToCpp
| FromCpp
deriving (Int -> CallDirection -> ShowS
[CallDirection] -> ShowS
CallDirection -> String
(Int -> CallDirection -> ShowS)
-> (CallDirection -> String)
-> ([CallDirection] -> ShowS)
-> Show CallDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallDirection] -> ShowS
$cshowList :: [CallDirection] -> ShowS
show :: CallDirection -> String
$cshow :: CallDirection -> String
showsPrec :: Int -> CallDirection -> ShowS
$cshowsPrec :: Int -> CallDirection -> ShowS
Show)
data CppCallType =
CallOp Operator
| CallFn (LC.Generator ())
| VarRead (LC.Generator ())
| VarWrite (LC.Generator ())
sayCppExportFn ::
ExtName
-> CppCallType
-> Maybe Type
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Bool
-> LC.Generator ()
sayCppExportFn :: ExtName
-> CppCallType
-> Maybe Type
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Bool
-> Generator ()
sayCppExportFn ExtName
extName CppCallType
callType Maybe Type
maybeThisType [Parameter]
params Type
retType ExceptionHandlers
exceptionHandlers Bool
sayBody = do
[ExceptionHandler]
handlerList <- ExceptionHandlers -> [ExceptionHandler]
exceptionHandlersList (ExceptionHandlers -> [ExceptionHandler])
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionHandlers
-> ReaderT Env (WriterT [Chunk] (Either String)) [ExceptionHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptionHandlers
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionHandlers
LC.getEffectiveExceptionHandlers ExceptionHandlers
exceptionHandlers
let paramTypes :: [Type]
paramTypes = (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType [Parameter]
params
catches :: Bool
catches = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ExceptionHandler] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExceptionHandler]
handlerList
addExceptionParamNames :: [String] -> [String]
addExceptionParamNames =
if Bool
catches then ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
LC.exceptionIdArgName, String
LC.exceptionPtrArgName]) else [String] -> [String]
forall a. a -> a
id
addExceptionParamTypes :: [Type] -> [Type]
addExceptionParamTypes = if Bool
catches then ([Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type -> Type
ptrT Type
intT, Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT Type
voidT]) else [Type] -> [Type]
forall a. a -> a
id
paramCount :: Int
paramCount = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
paramTypes
[Maybe Type]
paramCTypeMaybes <- (Type
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type))
-> [Type]
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
LC.typeToCType [Type]
paramTypes
let paramCTypes :: [Type]
paramCTypes = (Type -> Maybe Type -> Type) -> [Type] -> [Maybe Type] -> [Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe [Type]
paramTypes [Maybe Type]
paramCTypeMaybes
Maybe Type
retCTypeMaybe <- Type -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
LC.typeToCType Type
retType
let retCType :: Type
retCType = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
retType Maybe Type
retCTypeMaybe
Reqs -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Reqs -> m ()
LC.addReqsM (Reqs -> Generator ())
-> ([Reqs] -> Reqs) -> [Reqs] -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reqs] -> Reqs
forall a. Monoid a => [a] -> a
mconcat ([Reqs] -> Generator ())
-> ReaderT Env (WriterT [Chunk] (Either String)) [Reqs]
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Type -> ReaderT Env (WriterT [Chunk] (Either String)) Reqs)
-> [Type] -> ReaderT Env (WriterT [Chunk] (Either String)) [Reqs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> ReaderT Env (WriterT [Chunk] (Either String)) Reqs
LC.typeReqs (Type
retTypeType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
paramTypes)
String -> [String] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (ExtName -> String
LC.externalNameToCpp ExtName
extName)
(([String] -> [String])
-> (Type -> [String] -> [String])
-> Maybe Type
-> [String]
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String] -> [String]
forall a. a -> a
id (([String] -> [String]) -> Type -> [String] -> [String]
forall a b. a -> b -> a
const (String
"self"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)) Maybe Type
maybeThisType ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
[String] -> [String]
addExceptionParamNames ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
(Type -> Maybe Type -> Int -> String)
-> [Type] -> [Maybe Type] -> [Int] -> [String]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\Type
pt Maybe Type
ctm ->
let hasConversion :: Bool
hasConversion = case Type
pt of
Internal_TManual s ->
Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
-> Bool)
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
-> Bool
forall a b. (a -> b) -> a -> b
$ ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
conversionSpecCppConversionToCppExpr (ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ()))
-> ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
forall a b. (a -> b) -> a -> b
$
ConversionSpec -> ConversionSpecCpp
conversionSpecCpp ConversionSpec
s
Type
_ -> Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
ctm
in if Bool
hasConversion then Int -> String
LC.toArgNameAlt else Int -> String
LC.toArgName)
[Type]
paramTypes
[Maybe Type]
paramCTypeMaybes
[Int
1..Int
paramCount])
([Type] -> Type -> Type
fnT ([Type] -> [Type]
addExceptionParamTypes ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ ([Type] -> [Type])
-> (Type -> [Type] -> [Type]) -> Maybe Type -> [Type] -> [Type]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Type] -> [Type]
forall a. a -> a
id (:) Maybe Type
maybeThisType [Type]
paramCTypes)
Type
retCType) (Maybe (Generator ()) -> Generator ())
-> Maybe (Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$
if Bool -> Bool
not Bool
sayBody
then Maybe (Generator ())
forall a. Maybe a
Nothing
else Generator () -> Maybe (Generator ())
forall a. a -> Maybe a
Just (Generator () -> Maybe (Generator ()))
-> Generator () -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ do
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
catches (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"try {\n"
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"*", String
LC.exceptionIdArgName, String
" = 0;\n"]
((Int, Type, Maybe Type) -> Generator ())
-> [(Int, Type, Maybe Type)] -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CallDirection -> (Int, Type, Maybe Type) -> Generator ()
sayCppArgRead CallDirection
ToCpp) ([(Int, Type, Maybe Type)] -> Generator ())
-> [(Int, Type, Maybe Type)] -> Generator ()
forall a b. (a -> b) -> a -> b
$ [Int] -> [Type] -> [Maybe Type] -> [(Int, Type, Maybe Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
1..] [Type]
paramTypes [Maybe Type]
paramCTypeMaybes
let
sayCall :: Generator ()
sayCall = case CppCallType
callType of
CallOp Operator
op -> do
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"("
let effectiveParamCount :: Int
effectiveParamCount = Int
paramCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType then Int
1 else Int
0
paramNames :: [String]
paramNames@(String
p1:String
p2:[String]
_) = (if Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType then (String
"(*self)"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) else [String] -> [String]
forall a. a -> a
id) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
(Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
LC.toArgName [Int
1..]
assertParamCount :: Int -> Generator ()
assertParamCount Int
n =
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
effectiveParamCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall a. String -> Generator a
LC.abort (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"sayCppExportFn: Operator ", Operator -> String
forall a. Show a => a -> String
show Operator
op, String
" for export ", ExtName -> String
forall a. Show a => a -> String
show ExtName
extName,
String
" requires ", Int -> String
forall a. Show a => a -> String
show Int
n, String
" parameter(s), but has ", Int -> String
forall a. Show a => a -> String
show Int
effectiveParamCount,
String
"."]
case HasCallStack => Operator -> OperatorType
Operator -> OperatorType
operatorType Operator
op of
UnaryPrefixOperator String
symbol -> Int -> Generator ()
assertParamCount Int
1 Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
symbol, String
p1]
UnaryPostfixOperator String
symbol -> Int -> Generator ()
assertParamCount Int
1 Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
p1, String
symbol]
BinaryOperator String
symbol -> Int -> Generator ()
assertParamCount Int
2 Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
p1, String
symbol, String
p2]
OperatorType
CallOperator ->
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$ String
p1 String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Int
effectiveParamCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
paramNames) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
")"]
OperatorType
ArrayOperator -> Int -> Generator ()
assertParamCount Int
2 Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
p1, String
"[", String
p2, String
"]"]
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
")"
CallFn Generator ()
sayCppName -> do
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"self->"
Generator ()
sayCppName
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"("
Int -> Generator ()
sayCppArgNames Int
paramCount
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
")"
VarRead Generator ()
sayVarName -> do
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"self->"
Generator ()
sayVarName
VarWrite Generator ()
sayVarName -> do
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"self->"
Generator ()
sayVarName
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
" = ", Int -> String
LC.toArgName Int
1]
sayCallAndReturn :: Type -> Maybe Type -> Generator ()
sayCallAndReturn Type
retType' Maybe Type
retCTypeMaybe' = case (Type
retType', Maybe Type
retCTypeMaybe') of
(Type
Internal_TVoid, Maybe Type
Nothing) -> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
";\n"
(Internal_TManual ConversionSpec
s, Maybe Type
_) -> do
case ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
conversionSpecCppConversionToCppExpr (ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ()))
-> ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
forall a b. (a -> b) -> a -> b
$ ConversionSpec -> ConversionSpecCpp
conversionSpecCpp ConversionSpec
s of
Just Generator () -> Maybe (Generator ()) -> Generator ()
convFn -> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return " Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator () -> Maybe (Generator ()) -> Generator ()
convFn Generator ()
sayCall Maybe (Generator ())
forall a. Maybe a
Nothing Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
";\n"
Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
Nothing -> Generator ()
sayCallAndReturnDirect
(Type
_, Maybe Type
Nothing) -> Generator ()
sayCallAndReturnDirect
(Internal_TRef Type
cls, Just (Internal_TPtr Type
cls')) | Type
cls Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
cls' ->
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return &(" Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
");\n"
(Internal_TObj Class
cls,
Just (Internal_TPtr (Internal_TConst (Internal_TObj Class
cls')))) | Class
cls Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
cls' ->
Class -> Generator () -> Generator ()
forall (m :: * -> *) a.
MonadWriter [Chunk] m =>
Class -> m a -> m ()
sayReturnNew Class
cls Generator ()
sayCall
(Internal_TObjToHeap Class
cls, Just (Internal_TPtr (Internal_TObj Class
cls'))) | Class
cls Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
cls' ->
Class -> Generator () -> Generator ()
forall (m :: * -> *) a.
MonadWriter [Chunk] m =>
Class -> m a -> m ()
sayReturnNew Class
cls Generator ()
sayCall
(Internal_TToGc (Internal_TObj Class
cls),
Just (Internal_TPtr (Internal_TObj Class
cls'))) | Class
cls Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
cls' ->
Class -> Generator () -> Generator ()
forall (m :: * -> *) a.
MonadWriter [Chunk] m =>
Class -> m a -> m ()
sayReturnNew Class
cls Generator ()
sayCall
(Internal_TToGc Type
retType'', Maybe Type
_) -> Type -> Maybe Type -> Generator ()
sayCallAndReturn Type
retType'' Maybe Type
retCTypeMaybe'
(Type, Maybe Type)
ts -> String -> Generator ()
forall a. String -> Generator a
LC.abort (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"sayCppExportFn: Unexpected return types ", (Type, Maybe Type) -> String
forall a. Show a => a -> String
show (Type, Maybe Type)
ts,
String
" while generating binding for ", ExtName -> String
forall a. Show a => a -> String
show ExtName
extName, String
"."]
sayCallAndReturnDirect :: Generator ()
sayCallAndReturnDirect = String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return " Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
";\n"
Type -> Maybe Type -> Generator ()
sayCallAndReturn Type
retType Maybe Type
retCTypeMaybe
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
catches (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
Interface
iface <- ReaderT Env (WriterT [Chunk] (Either String)) Interface
forall (m :: * -> *). MonadReader Env m => m Interface
LC.askInterface
[ExceptionHandler]
-> (ExceptionHandler -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ExceptionHandler]
handlerList ((ExceptionHandler -> Generator ()) -> Generator ())
-> (ExceptionHandler -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \ExceptionHandler
handler -> do
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"} catch ("
case ExceptionHandler
handler of
CatchClass Class
cls -> String -> Maybe [String] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
String -> Maybe [String] -> Type -> m ()
LC.sayVar String
LC.exceptionVarName Maybe [String]
forall a. Maybe a
Nothing (Type -> Generator ()) -> Type -> Generator ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
refT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
constT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls
ExceptionHandler
CatchAll -> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"..."
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
") {\n"
ExceptionId
exceptionId <- case ExceptionHandler
handler of
CatchClass Class
cls -> case Interface -> Class -> Maybe ExceptionId
interfaceExceptionClassId Interface
iface Class
cls of
Just ExceptionId
exceptionId -> ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId
forall (m :: * -> *) a. Monad m => a -> m a
return ExceptionId
exceptionId
Maybe ExceptionId
Nothing -> String -> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId
forall a. String -> Generator a
LC.abort (String
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId)
-> String
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"sayCppExportFn: Trying to catch non-exception class ", Class -> String
forall a. Show a => a -> String
show Class
cls,
String
" while generating binding for ", ExtName -> String
forall a. Show a => a -> String
show ExtName
extName, String
"."]
ExceptionHandler
CatchAll -> ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId
forall (m :: * -> *) a. Monad m => a -> m a
return ExceptionId
exceptionCatchAllId
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"*", String
LC.exceptionIdArgName, String
" = ", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
exceptionId, String
";\n"]
case ExceptionHandler
handler of
ExceptionHandler
CatchAll -> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"*", String
LC.exceptionPtrArgName, String
" = 0;\n"]
CatchClass Class
cls -> do
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"*", String
LC.exceptionPtrArgName, String
" = reinterpret_cast<void*>(new "]
Maybe [String] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [String] -> Type -> m ()
LC.sayType Maybe [String]
forall a. Maybe a
Nothing (Type -> Generator ()) -> Type -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"(", String
LC.exceptionVarName, String
"));\n"]
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type
retType Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
Internal_TVoid) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return 0;\n"
String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"}\n"
where sayReturnNew :: Class -> m a -> m ()
sayReturnNew Class
cls m a
sayCall =
String -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return new" m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Identifier -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier (Class -> Identifier
Class.classIdentifier Class
cls) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"(" m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
m a
sayCall m a -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
");\n"
sayCppArgRead :: CallDirection -> (Int, Type, Maybe Type) -> LC.Generator ()
sayCppArgRead :: CallDirection -> (Int, Type, Maybe Type) -> Generator ()
sayCppArgRead CallDirection
dir (Int
n, Type -> Type
stripConst (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
normalizeType -> Type
cppType, Maybe Type
maybeCType) = case Type
cppType of
t :: Type
t@(Internal_TPtr (Internal_TFn [Parameter]
params Type
retType)) -> do
let paramTypes :: [Type]
paramTypes = (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType [Parameter]
params
check :: String
-> Type
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
check String
label Type
t' = ((String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t') String -> Maybe Type -> Maybe String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Maybe Type -> Maybe String)
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
LC.typeToCType Type
t'
[String]
mismatches <-
([Maybe String] -> [String])
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
-> ReaderT Env (WriterT [Chunk] (Either String)) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
-> ReaderT Env (WriterT [Chunk] (Either String)) [String])
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
-> ReaderT Env (WriterT [Chunk] (Either String)) [String]
forall a b. (a -> b) -> a -> b
$
(:) (Maybe String -> [Maybe String] -> [Maybe String])
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
-> ReaderT
Env
(WriterT [Chunk] (Either String))
([Maybe String] -> [Maybe String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Type
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
check String
"return type" Type
retType
ReaderT
Env
(WriterT [Chunk] (Either String))
([Maybe String] -> [Maybe String])
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String))
-> [Type]
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Type
paramType -> String
-> Type
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
check String
"parameter" Type
paramType) [Type]
paramTypes
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
mismatches) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
String -> Generator ()
forall a. String -> Generator a
LC.abort (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
String
"sayCppArgRead: Some types within a function pointer type use non-C types, " String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
String
"but only C types may be used. The unsupported types are: " String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"; " [String]
mismatches [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
". The whole function type is ", Type -> String
forall a. Show a => a -> String
show Type
t, String
"."]
Generator ()
convertDefault
Internal_TRef Type
t -> Type -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Type -> m ()
convertObj Type
t
Internal_TObj Class
_ -> Type -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Type -> m ()
convertObj (Type -> Generator ()) -> Type -> Generator ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
constT Type
cppType
Internal_TObjToHeap Class
cls -> case CallDirection
dir of
CallDirection
ToCpp -> String -> Generator ()
forall a. HasCallStack => String -> a
error (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Class -> String
objToHeapTWrongDirectionErrorMsg (String -> Maybe String
forall a. a -> Maybe a
Just String
"sayCppArgRead") Class
cls
CallDirection
FromCpp -> do
Identifier -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier (Identifier -> Generator ()) -> Identifier -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Identifier
Class.classIdentifier Class
cls
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"* ", Int -> String
LC.toArgName Int
n, String
" = new "]
Identifier -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier (Identifier -> Generator ()) -> Identifier -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Identifier
Class.classIdentifier Class
cls
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"(", Int -> String
LC.toArgNameAlt Int
n, String
");\n"]
Internal_TToGc Type
t' -> case CallDirection
dir of
CallDirection
ToCpp -> String -> Generator ()
forall a. HasCallStack => String -> a
error (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
toGcTWrongDirectionErrorMsg (String -> Maybe String
forall a. a -> Maybe a
Just String
"sayCppArgRead") Type
t'
CallDirection
FromCpp -> do
let newCppType :: Type
newCppType = case Type
t' of
Internal_TObj Class
cls -> Class -> Type
objToHeapT Class
cls
Type
_ -> Type
t'
Maybe Type
cType <- Type -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
LC.typeToCType Type
newCppType
CallDirection -> (Int, Type, Maybe Type) -> Generator ()
sayCppArgRead CallDirection
dir (Int
n, Type
newCppType, Maybe Type
cType)
Internal_TManual ConversionSpec
s -> do
let maybeConvExpr :: Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
maybeConvExpr =
(case CallDirection
dir of
CallDirection
ToCpp -> ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
conversionSpecCppConversionToCppExpr
CallDirection
FromCpp -> ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
conversionSpecCppConversionFromCppExpr) (ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ()))
-> ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
forall a b. (a -> b) -> a -> b
$
ConversionSpec -> ConversionSpecCpp
conversionSpecCpp ConversionSpec
s
Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
-> ((Generator () -> Maybe (Generator ()) -> Generator ())
-> Generator ())
-> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
maybeConvExpr (((Generator () -> Maybe (Generator ()) -> Generator ())
-> Generator ())
-> Generator ())
-> ((Generator () -> Maybe (Generator ()) -> Generator ())
-> Generator ())
-> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator () -> Maybe (Generator ()) -> Generator ()
gen ->
Generator () -> Maybe (Generator ()) -> Generator ()
gen (String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Int -> String
LC.toArgNameAlt Int
n) (Generator () -> Maybe (Generator ())
forall a. a -> Maybe a
Just (Generator () -> Maybe (Generator ()))
-> Generator () -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Int -> String
LC.toArgName Int
n)
Type
_ -> Generator ()
convertDefault
where
convertDefault :: Generator ()
convertDefault = Maybe Type
-> (Type -> ReaderT Env (WriterT [Chunk] (Either String)) Any)
-> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Type
maybeCType ((Type -> ReaderT Env (WriterT [Chunk] (Either String)) Any)
-> Generator ())
-> (Type -> ReaderT Env (WriterT [Chunk] (Either String)) Any)
-> Generator ()
forall a b. (a -> b) -> a -> b
$ \Type
cType ->
String -> ReaderT Env (WriterT [Chunk] (Either String)) Any
forall a. String -> Generator a
LC.abort (String -> ReaderT Env (WriterT [Chunk] (Either String)) Any)
-> String -> ReaderT Env (WriterT [Chunk] (Either String)) Any
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"sayCppArgRead: Don't know how to convert ", CallDirection -> String
forall a. Show a => a -> String
show CallDirection
dir, String
" between C-type ", Type -> String
forall a. Show a => a -> String
show Type
cType,
String
" and C++-type ", Type -> String
forall a. Show a => a -> String
show Type
cppType, String
"."]
convertObj :: Type -> m ()
convertObj Type
cppType' = case CallDirection
dir of
CallDirection
ToCpp -> do
String -> Maybe [String] -> Type -> m ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
String -> Maybe [String] -> Type -> m ()
LC.sayVar (Int -> String
LC.toArgName Int
n) Maybe [String]
forall a. Maybe a
Nothing (Type -> m ()) -> Type -> m ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
refT Type
cppType'
[String] -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
" = *", Int -> String
LC.toArgNameAlt Int
n, String
";\n"]
CallDirection
FromCpp -> do
String -> Maybe [String] -> Type -> m ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
String -> Maybe [String] -> Type -> m ()
LC.sayVar (Int -> String
LC.toArgName Int
n) Maybe [String]
forall a. Maybe a
Nothing (Type -> m ()) -> Type -> m ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT Type
cppType'
[String] -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
" = &", Int -> String
LC.toArgNameAlt Int
n, String
";\n"]
sayCppArgNames :: Int -> LC.Generator ()
sayCppArgNames :: Int -> Generator ()
sayCppArgNames Int
count =
[String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
LC.toArgName [Int
1..Int
count]
sayHsExport :: LH.SayExportMode -> Function -> LH.Generator ()
sayHsExport :: SayExportMode -> Function -> Generator ()
sayHsExport SayExportMode
mode Function
fn =
(SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
sayHsExportFn SayExportMode
mode (ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ())
-> (Function -> ExtName)
-> Function
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Function -> ExtName
fnExtName (Function
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ())
-> (Function -> ExtName)
-> Function
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> ExtName
fnExtName (Function
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ())
-> (Function -> Purity)
-> Function
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> Purity
fnPurity (Function
-> [Parameter] -> Type -> ExceptionHandlers -> Generator ())
-> (Function -> [Parameter])
-> Function
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Function -> [Parameter]
fnParams (Function -> Type -> ExceptionHandlers -> Generator ())
-> (Function -> Type)
-> Function
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> Type
fnReturn (Function -> ExceptionHandlers -> Generator ())
-> (Function -> ExceptionHandlers) -> Function -> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> ExceptionHandlers
fnExceptionHandlers) Function
fn
sayHsExportFn ::
LH.SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> LH.Generator ()
sayHsExportFn :: SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
sayHsExportFn SayExportMode
mode ExtName
extName ExtName
foreignName Purity
purity [Parameter]
params Type
retType ExceptionHandlers
exceptionHandlers = do
ExceptionHandlers
effectiveHandlers <- ExceptionHandlers -> Generator ExceptionHandlers
LH.getEffectiveExceptionHandlers ExceptionHandlers
exceptionHandlers
let handlerList :: [ExceptionHandler]
handlerList = ExceptionHandlers -> [ExceptionHandler]
exceptionHandlersList ExceptionHandlers
effectiveHandlers
catches :: Bool
catches = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ExceptionHandler] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExceptionHandler]
handlerList
paramTypes :: [Type]
paramTypes = (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType [Parameter]
params
let hsFnName :: String
hsFnName = ExtName -> String
LH.toHsFnName' ExtName
foreignName
hsFnImportedName :: String
hsFnImportedName = String
hsFnName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
case SayExportMode
mode of
SayExportMode
LH.SayExportForeignImports ->
String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"generating imports for function " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> String
forall a. Show a => a -> String
show ExtName
extName) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
FnHsType
hsCType <- HsTypeSide
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator FnHsType
fnToHsTypeAndUse HsTypeSide
LH.HsCSide Purity
purity [Parameter]
params Type
retType ExceptionHandlers
effectiveHandlers
[String] -> Generator ()
LH.saysLn [String
"foreign import ccall \"", ExtName -> String
LC.externalNameToCpp ExtName
extName, String
"\" ", String
hsFnImportedName,
String
" :: ", FnHsType -> String
renderFnHsType FnHsType
hsCType]
SayExportMode
LH.SayExportDecls -> String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"generating function " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> String
forall a. Show a => a -> String
show ExtName
extName) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
Generator ()
LH.ln
String -> Generator ()
LH.addExport String
hsFnName
FnHsType
hsHsType <- HsTypeSide
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator FnHsType
fnToHsTypeAndUse HsTypeSide
LH.HsHsSide Purity
purity [Parameter]
params Type
retType ExceptionHandlers
effectiveHandlers
[String] -> Generator ()
LH.saysLn [String
hsFnName, String
" :: ", FnHsType -> String
renderFnHsTypeWithNames FnHsType
hsHsType]
case Purity
purity of
Purity
Nonpure -> () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Purity
Pure -> [String] -> Generator ()
LH.saysLn [String
"{-# NOINLINE ", String
hsFnName, String
" #-}"]
let argNames :: [String]
argNames = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
LH.toArgName [Int
1..[Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
paramTypes]
convertedArgNames :: [String]
convertedArgNames = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'") [String]
argNames
[String]
lineEnd <- case Purity
purity of
Purity
Nonpure -> [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
" ="]
Purity
Pure -> do HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)", HsImportSet
hsImportForUnsafeIO]
[String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
" = HoppySIU.unsafePerformIO $"]
[String] -> Generator ()
LH.saysLn ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$ String
hsFnName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) [String]
argNames [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
lineEnd
Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
[(Type, String, String)]
-> ((Type, String, String) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Type] -> [String] -> [String] -> [(Type, String, String)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Type]
paramTypes [String]
argNames [String]
convertedArgNames) (((Type, String, String) -> Generator ()) -> Generator ())
-> ((Type, String, String) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \(Type
t, String
argName, String
argName') ->
CallDirection -> Type -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
ToCpp Type
t String
argName String
argName'
String
exceptionHandling <-
if Bool
catches
then do Interface
iface <- Generator Interface
LH.askInterface
Module
currentModule <- Generator Module
LH.askModule
let exceptionSupportModule :: Maybe Module
exceptionSupportModule = Interface -> Maybe Module
interfaceExceptionSupportModule Interface
iface
Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Module
exceptionSupportModule Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> Maybe Module
forall a. a -> Maybe a
Just Module
currentModule) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ())
-> (Module -> HsImportSet) -> Module -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsImportSet
hsWholeModuleImport (String -> HsImportSet)
-> (Module -> String) -> Module -> HsImportSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Module -> String
LH.getModuleName Interface
iface (Module -> Generator ()) -> Generator Module -> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
Generator Module -> Maybe Module -> Generator Module
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (String -> Generator Module
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
String
"Internal error, an exception support module is not available")
Maybe Module
exceptionSupportModule
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)", HsImportSet
hsImportForRuntime]
String -> ReaderT Env (WriterT Output (Except String)) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"HoppyFHR.internalHandleExceptions exceptionDb' $"
else String -> ReaderT Env (WriterT Output (Except String)) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
let callWords :: [String]
callWords = String
exceptionHandling String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
hsFnImportedName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) [String]
convertedArgNames
CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
ToCpp Type
retType [String]
callWords
SayExportMode
LH.SayExportBoot ->
() -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sayHsArgProcessing ::
CallDirection
-> Type
-> String
-> String
-> LH.Generator ()
sayHsArgProcessing :: CallDirection -> Type -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
dir Type
t String
fromVar String
toVar =
String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"processing argument of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
case Type
t of
Type
Internal_TVoid -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ String
"TVoid is not a valid argument type"
Internal_TPtr (Internal_TObj Class
cls) -> case CallDirection
dir of
CallDirection
ToCpp -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)",
HsImportSet
hsImportForRuntime]
String
castMethodName <- Constness
-> Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsCastMethodName Constness
Nonconst Class
cls
[String] -> Generator ()
LH.saysLn [String
"HoppyFHR.withCppPtr (", String
castMethodName, String
" ", String
fromVar,
String
") $ \\", String
toVar, String
" ->"]
CallDirection
FromCpp -> do
String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
[String] -> Generator ()
LH.saysLn [String
"let ", String
toVar, String
" = ", String
ctorName, String
" ", String
fromVar, String
" in"]
Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> case CallDirection
dir of
CallDirection
ToCpp -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)",
HsImportSet
hsImportForPrelude,
HsImportSet
hsImportForRuntime]
String
withValuePtrName <- Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsWithValuePtrName Class
cls
[String] -> Generator ()
LH.saysLn [String
withValuePtrName, String
" ", String
fromVar,
String
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", String
toVar, String
" ->"]
CallDirection
FromCpp -> do
String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
[String] -> Generator ()
LH.saysLn [String
"let ", String
toVar, String
" = ", String
ctorName, String
" ", String
fromVar, String
" in"]
Internal_TPtr Type
_ -> Generator ()
noConversion
Internal_TRef Type
t' -> CallDirection -> Type -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
dir (Type -> Type
ptrT Type
t') String
fromVar String
toVar
Internal_TFn {} -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"TFn unimplemented"
Internal_TObj Class
cls -> case CallDirection
dir of
CallDirection
ToCpp -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)",
HsImportSet
hsImportForPrelude,
HsImportSet
hsImportForRuntime]
String
withValuePtrName <- Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsWithValuePtrName Class
cls
[String] -> Generator ()
LH.saysLn [String
withValuePtrName, String
" ", String
fromVar,
String
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", String
toVar, String
" ->"]
CallDirection
FromCpp -> case ClassHaskellConversion -> Maybe (Generator ())
Class.classHaskellConversionFromCppFn (ClassHaskellConversion -> Maybe (Generator ()))
-> ClassHaskellConversion -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ Class -> ClassHaskellConversion
LH.getClassHaskellConversion Class
cls of
Just Generator ()
_ -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(>>=)",
HsImportSet
hsImportForRuntime]
String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
[String] -> Generator ()
LH.saysLn [String
"HoppyFHR.decode (", String
ctorName, String
" ", String
fromVar, String
") >>= \\", String
toVar, String
" ->"]
Maybe (Generator ())
Nothing ->
String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"Can't pass a TObj of ", Class -> String
forall a. Show a => a -> String
show Class
cls,
String
" from C++ to Haskell because no class decode conversion is defined"]
Internal_TObjToHeap Class
cls -> case CallDirection
dir of
CallDirection
ToCpp -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Class -> String
objToHeapTWrongDirectionErrorMsg Maybe String
forall a. Maybe a
Nothing Class
cls
CallDirection
FromCpp -> CallDirection -> Type -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
dir (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) String
fromVar String
toVar
Internal_TToGc Type
t' -> case CallDirection
dir of
CallDirection
ToCpp -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
toGcTWrongDirectionErrorMsg Maybe String
forall a. Maybe a
Nothing Type
t'
CallDirection
FromCpp -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(>>=)",
HsImportSet
hsImportForRuntime]
String
ctorName <-
ReaderT Env (WriterT Output (Except String)) String
-> (Class -> ReaderT Env (WriterT Output (Except String)) String)
-> Maybe Class
-> ReaderT Env (WriterT Output (Except String)) String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ReaderT Env (WriterT Output (Except String)) String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (WriterT Output (Except String)) String)
-> String -> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
tToGcInvalidFormErrorMessage Maybe String
forall a. Maybe a
Nothing Type
t')
(Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst) (Maybe Class
-> ReaderT Env (WriterT Output (Except String)) String)
-> Maybe Class
-> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$
case Type -> Type
stripConst Type
t' of
Internal_TObj Class
cls -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
Internal_TRef (Internal_TConst (Internal_TObj Class
cls)) -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
Internal_TRef (Internal_TObj Class
cls) -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
Internal_TPtr (Internal_TObj Class
cls) -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
Type
_ -> Maybe Class
forall a. Maybe a
Nothing
[String] -> Generator ()
LH.saysLn [String
"HoppyFHR.toGc (", String
ctorName, String
" ", String
fromVar, String
") >>= \\", String
toVar, String
" ->"]
Internal_TConst Type
t' -> CallDirection -> Type -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
dir Type
t' String
fromVar String
toVar
Internal_TManual ConversionSpec
s -> do
let maybeGen :: Maybe (ConversionMethod (Generator ()))
maybeGen =
(ConversionSpecHaskell -> ConversionMethod (Generator ()))
-> Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (case CallDirection
dir of
CallDirection
ToCpp -> ConversionSpecHaskell -> ConversionMethod (Generator ())
conversionSpecHaskellToCppFn
CallDirection
FromCpp -> ConversionSpecHaskell -> ConversionMethod (Generator ())
conversionSpecHaskellFromCppFn) (Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ())))
-> Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ()))
forall a b. (a -> b) -> a -> b
$
ConversionSpec -> Maybe ConversionSpecHaskell
conversionSpecHaskell ConversionSpec
s
throwForNoConversion :: ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion =
String -> ReaderT Env (WriterT Output (Except String)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (WriterT Output (Except String)) a)
-> String -> ReaderT Env (WriterT Output (Except String)) a
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"No conversion defined for ", ConversionSpec -> String
forall a. Show a => a -> String
show ConversionSpec
s,
case CallDirection
dir of
CallDirection
ToCpp -> String
" to C++ from Haskell"
CallDirection
FromCpp -> String
" from C++ to Haskell"]
case Maybe (ConversionMethod (Generator ()))
maybeGen of
Just (CustomConversion Generator ()
gen) -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(>>=)"
String -> Generator ()
LH.sayLn String
"("
Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent Generator ()
gen
[String] -> Generator ()
LH.saysLn [String
") ", String
fromVar, String
" >>= \\", String
toVar, String
" ->"]
Just ConversionMethod (Generator ())
BinaryCompatible -> [String] -> Generator ()
LH.saysLn [String
"let ", String
toVar, String
" = ", String
fromVar, String
" in"]
Just ConversionMethod (Generator ())
ConversionUnsupported -> Generator ()
forall a. ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion
Maybe (ConversionMethod (Generator ()))
Nothing -> Generator ()
forall a. ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion
where noConversion :: Generator ()
noConversion = [String] -> Generator ()
LH.saysLn [String
"let ", String
toVar, String
" = ", String
fromVar, String
" in"]
sayHsCallAndProcessReturn :: CallDirection -> Type -> [String] -> LH.Generator ()
sayHsCallAndProcessReturn :: CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t [String]
callWords =
String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"processing return value of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
case Type
t of
Type
Internal_TVoid -> Generator ()
sayCall
Internal_TPtr (Internal_TObj Class
cls) -> do
case CallDirection
dir of
CallDirection
ToCpp -> do
HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
[String] -> Generator ()
LH.saysLn [String
"HoppyP.fmap ", String
ctorName]
Generator ()
sayCall
CallDirection
FromCpp -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
hsImportForPrelude, HsImportSet
hsImportForRuntime]
String -> Generator ()
LH.sayLn String
"HoppyP.fmap HoppyFHR.toPtr"
Generator ()
sayCall
Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> case CallDirection
dir of
CallDirection
ToCpp -> do
HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
[String] -> Generator ()
LH.saysLn [String
"HoppyP.fmap ", String
ctorName]
Generator ()
sayCall
CallDirection
FromCpp -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
hsImportForPrelude, HsImportSet
hsImportForRuntime]
String -> Generator ()
LH.sayLn String
"HoppyP.fmap HoppyFHR.toPtr"
Generator ()
sayCall
Internal_TPtr Type
_ -> Generator ()
sayCall
Internal_TRef Type
t' -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT Type
t') [String]
callWords
Internal_TFn {} -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"TFn unimplemented"
Internal_TObj Class
cls -> case CallDirection
dir of
CallDirection
ToCpp -> case ClassHaskellConversion -> Maybe (Generator ())
Class.classHaskellConversionFromCppFn (ClassHaskellConversion -> Maybe (Generator ()))
-> ClassHaskellConversion -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ Class -> ClassHaskellConversion
LH.getClassHaskellConversion Class
cls of
Just Generator ()
_ -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> [String] -> HsImportSet
hsImports String
"Prelude" [String
"(.)", String
"(=<<)"],
HsImportSet
hsImportForRuntime]
String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
[String] -> Generator ()
LH.saysLn [String
"(HoppyFHR.decodeAndDelete . ", String
ctorName, String
") =<<"]
Generator ()
sayCall
Maybe (Generator ())
Nothing ->
String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"Can't return a TObj of ", Class -> String
forall a. Show a => a -> String
show Class
cls,
String
" from C++ to Haskell because no class decode conversion is defined"]
CallDirection
FromCpp -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> [String] -> HsImportSet
hsImports String
"Prelude" [String
"(.)", String
"(=<<)"],
HsImportSet
hsImportForPrelude,
HsImportSet
hsImportForRuntime]
String -> Generator ()
LH.sayLn String
"(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<"
Generator ()
sayCall
Internal_TObjToHeap Class
cls -> case CallDirection
dir of
CallDirection
ToCpp -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) [String]
callWords
CallDirection
FromCpp -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Class -> String
objToHeapTWrongDirectionErrorMsg Maybe String
forall a. Maybe a
Nothing Class
cls
Internal_TToGc Type
t' -> case CallDirection
dir of
CallDirection
ToCpp -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(=<<)",
HsImportSet
hsImportForRuntime]
String -> Generator ()
LH.sayLn String
"HoppyFHR.toGc =<<"
case Type
t' of
Internal_TObj Class
_ -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT Type
t') [String]
callWords
Type
_ -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t' [String]
callWords
CallDirection
FromCpp -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
toGcTWrongDirectionErrorMsg Maybe String
forall a. Maybe a
Nothing Type
t'
Internal_TConst Type
t' -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t' [String]
callWords
Internal_TManual ConversionSpec
s -> do
let maybeGen :: Maybe (ConversionMethod (Generator ()))
maybeGen =
(ConversionSpecHaskell -> ConversionMethod (Generator ()))
-> Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (case CallDirection
dir of
CallDirection
ToCpp -> ConversionSpecHaskell -> ConversionMethod (Generator ())
conversionSpecHaskellFromCppFn
CallDirection
FromCpp -> ConversionSpecHaskell -> ConversionMethod (Generator ())
conversionSpecHaskellToCppFn) (Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ())))
-> Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ()))
forall a b. (a -> b) -> a -> b
$
ConversionSpec -> Maybe ConversionSpecHaskell
conversionSpecHaskell ConversionSpec
s
throwForNoConversion :: ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion =
String -> ReaderT Env (WriterT Output (Except String)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (WriterT Output (Except String)) a)
-> String -> ReaderT Env (WriterT Output (Except String)) a
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"No conversion defined for ", ConversionSpec -> String
forall a. Show a => a -> String
show ConversionSpec
s,
case CallDirection
dir of
CallDirection
ToCpp -> String
" from C++ to Haskell"
CallDirection
FromCpp -> String
" to C++ from Haskell"]
case Maybe (ConversionMethod (Generator ()))
maybeGen of
Just (CustomConversion Generator ()
gen) -> do
HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(=<<)"
String -> Generator ()
LH.sayLn String
"("
Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent Generator ()
gen
String -> Generator ()
LH.sayLn String
") =<<"
Just ConversionMethod (Generator ())
BinaryCompatible -> () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ConversionMethod (Generator ())
ConversionUnsupported -> Generator ()
forall a. ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion
Maybe (ConversionMethod (Generator ()))
Nothing -> Generator ()
forall a. ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion
Generator ()
sayCall
where sayCall :: Generator ()
sayCall = [String] -> Generator ()
LH.saysLn ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$ String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
callWords [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
")"]
data FnHsType = FnHsType
{ FnHsType -> HsQualType
fnHsQualType :: HsQualType
, FnHsType -> [Maybe String]
fnHsParamNameMaybes :: [Maybe String]
}
fnToHsTypeAndUse ::
LH.HsTypeSide
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> LH.Generator FnHsType
fnToHsTypeAndUse :: HsTypeSide
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator FnHsType
fnToHsTypeAndUse HsTypeSide
side Purity
purity [Parameter]
params Type
returnType ExceptionHandlers
exceptionHandlers = do
let catches :: Bool
catches = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ExceptionHandler] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ExceptionHandler] -> Bool) -> [ExceptionHandler] -> Bool
forall a b. (a -> b) -> a -> b
$ ExceptionHandlers -> [ExceptionHandler]
exceptionHandlersList ExceptionHandlers
exceptionHandlers
getsExcParams :: Bool
getsExcParams = Bool
catches Bool -> Bool -> Bool
&& HsTypeSide
side HsTypeSide -> HsTypeSide -> Bool
forall a. Eq a => a -> a -> Bool
== HsTypeSide
LH.HsCSide
paramTypes :: [Type]
paramTypes =
(if Bool
getsExcParams then ([Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type -> Type
ptrT Type
intT, Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT Type
voidT]) else [Type] -> [Type]
forall a. a -> a
id) ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
(Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType [Parameter]
params
paramNameMaybes :: [Maybe String]
paramNameMaybes =
(if Bool
getsExcParams then ([Maybe String] -> [Maybe String] -> [Maybe String]
forall a. [a] -> [a] -> [a]
++ [String -> Maybe String
forall a. a -> Maybe a
Just String
"excId", String -> Maybe String
forall a. a -> Maybe a
Just String
"excPtr"]) else [Maybe String] -> [Maybe String]
forall a. a -> a
id) ([Maybe String] -> [Maybe String])
-> [Maybe String] -> [Maybe String]
forall a b. (a -> b) -> a -> b
$
(Parameter -> Maybe String) -> [Parameter] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Maybe String
parameterName [Parameter]
params
defaultParamNames :: [String]
defaultParamNames = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
LH.toArgName [Int
1..]
defaultedParamNames :: [String]
defaultedParamNames = (String -> Maybe String -> String)
-> [String] -> [Maybe String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe [String]
defaultParamNames [Maybe String]
paramNameMaybes
[HsQualType]
paramQualTypes <- ((String, Type)
-> ReaderT Env (WriterT Output (Except String)) HsQualType)
-> [(String, Type)]
-> ReaderT Env (WriterT Output (Except String)) [HsQualType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, Type)
-> ReaderT Env (WriterT Output (Except String)) HsQualType
contextForParam ([(String, Type)]
-> ReaderT Env (WriterT Output (Except String)) [HsQualType])
-> [(String, Type)]
-> ReaderT Env (WriterT Output (Except String)) [HsQualType]
forall a b. (a -> b) -> a -> b
$ [String] -> [Type] -> [(String, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
defaultedParamNames [Type]
paramTypes
let context :: HsContext
context = (HsQualType -> HsContext) -> [HsQualType] -> HsContext
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(HsQualType HsContext
ctx HsType
_) -> HsContext
ctx) [HsQualType]
paramQualTypes :: HsContext
hsParams :: [HsType]
hsParams = (HsQualType -> HsType) -> [HsQualType] -> [HsType]
forall a b. (a -> b) -> [a] -> [b]
map (\(HsQualType HsContext
_ HsType
t) -> HsType
t) [HsQualType]
paramQualTypes
HsType
hsReturnInitial <- HsTypeSide -> Type -> Generator HsType
LH.cppTypeToHsTypeAndUse HsTypeSide
side Type
returnType
HsType
hsReturnForPurity <- case (Purity
purity, HsTypeSide
side) of
(Purity
Pure, HsTypeSide
LH.HsHsSide) -> HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return HsType
hsReturnInitial
(Purity, HsTypeSide)
_ -> do
HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType -> Generator HsType) -> HsType -> Generator HsType
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"HoppyP.IO") HsType
hsReturnInitial
FnHsType -> Generator FnHsType
forall (m :: * -> *) a. Monad m => a -> m a
return FnHsType :: HsQualType -> [Maybe String] -> FnHsType
FnHsType
{ fnHsQualType :: HsQualType
fnHsQualType = HsContext -> HsType -> HsQualType
HsQualType HsContext
context (HsType -> HsQualType) -> HsType -> HsQualType
forall a b. (a -> b) -> a -> b
$ (HsType -> HsType -> HsType) -> HsType -> [HsType] -> HsType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsType -> HsType -> HsType
HsTyFun HsType
hsReturnForPurity [HsType]
hsParams
, fnHsParamNameMaybes :: [Maybe String]
fnHsParamNameMaybes = [Maybe String]
paramNameMaybes
}
where contextForParam :: (String, Type) -> LH.Generator HsQualType
contextForParam :: (String, Type)
-> ReaderT Env (WriterT Output (Except String)) HsQualType
contextForParam (String
s, Type
t) = case Type
t of
Internal_TPtr (Internal_TObj Class
cls) -> String
-> Class
-> Constness
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receivePtr String
s Class
cls Constness
Nonconst
Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> String
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receiveValue String
s Type
t Class
cls
Internal_TRef (Internal_TObj Class
cls) -> String
-> Class
-> Constness
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receivePtr String
s Class
cls Constness
Nonconst
Internal_TRef (Internal_TConst (Internal_TObj Class
cls)) -> String
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receiveValue String
s Type
t Class
cls
Internal_TObj Class
cls -> String
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receiveValue String
s Type
t Class
cls
Internal_TManual ConversionSpec
spec ->
case (HsTypeSide
side, ConversionSpec -> Maybe ConversionSpecHaskell
conversionSpecHaskell ConversionSpec
spec Maybe ConversionSpecHaskell
-> (ConversionSpecHaskell
-> Maybe
(HsName
-> ReaderT Env (WriterT Output (Except String)) HsQualType))
-> Maybe
(HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConversionSpecHaskell
-> Maybe
(HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType)
conversionSpecHaskellHsArgType) of
(HsTypeSide
LH.HsHsSide, Just HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType
f) -> HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType
f (HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType)
-> HsName
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
s
(HsTypeSide,
Maybe
(HsName
-> ReaderT Env (WriterT Output (Except String)) HsQualType))
_ -> HsTypeSide
-> Type -> ReaderT Env (WriterT Output (Except String)) HsQualType
handoff HsTypeSide
side Type
t
Internal_TConst Type
t' -> (String, Type)
-> ReaderT Env (WriterT Output (Except String)) HsQualType
contextForParam (String
s, Type
t')
Type
_ -> HsTypeSide
-> Type -> ReaderT Env (WriterT Output (Except String)) HsQualType
handoff HsTypeSide
side Type
t
handoff :: LH.HsTypeSide -> Type -> LH.Generator HsQualType
handoff :: HsTypeSide
-> Type -> ReaderT Env (WriterT Output (Except String)) HsQualType
handoff HsTypeSide
side' Type
t = HsContext -> HsType -> HsQualType
HsQualType [] (HsType -> HsQualType)
-> Generator HsType
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsTypeSide -> Type -> Generator HsType
LH.cppTypeToHsTypeAndUse HsTypeSide
side' Type
t
receivePtr :: String -> Class.Class -> Constness -> LH.Generator HsQualType
receivePtr :: String
-> Class
-> Constness
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receivePtr String
s Class
cls Constness
cst = case HsTypeSide
side of
HsTypeSide
LH.HsHsSide -> do
String
ptrClassName <- Constness
-> Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsPtrClassName Constness
cst Class
cls
let t' :: HsType
t' = HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
s
HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType)
-> HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall a b. (a -> b) -> a -> b
$ HsContext -> HsType -> HsQualType
HsQualType [(HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
ptrClassName, [HsType
t'])] HsType
t'
HsTypeSide
LH.HsCSide -> do
HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForForeign
String
typeName <- Constness
-> Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataTypeName Constness
cst Class
cls
HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType)
-> HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall a b. (a -> b) -> a -> b
$
HsContext -> HsType -> HsQualType
HsQualType [] (HsType -> HsQualType) -> HsType -> HsQualType
forall a b. (a -> b) -> a -> b
$
HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"HoppyF.Ptr")
(HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
typeName)
receiveValue :: String -> Type -> Class.Class -> LH.Generator HsQualType
receiveValue :: String
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receiveValue String
s Type
t Class
cls = case HsTypeSide
side of
HsTypeSide
LH.HsCSide -> HsTypeSide
-> Type -> ReaderT Env (WriterT Output (Except String)) HsQualType
handoff HsTypeSide
side Type
t
HsTypeSide
LH.HsHsSide -> do
HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
String
valueClassName <- Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsValueClassName Class
cls
let t' :: HsType
t' = HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
s
HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType)
-> HsQualType
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall a b. (a -> b) -> a -> b
$ HsContext -> HsType -> HsQualType
HsQualType [(HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
valueClassName, [HsType
t'])] HsType
t'
renderFnHsType :: FnHsType -> String
renderFnHsType :: FnHsType -> String
renderFnHsType = HsQualType -> String
forall a. Pretty a => a -> String
LH.prettyPrint (HsQualType -> String)
-> (FnHsType -> HsQualType) -> FnHsType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FnHsType -> HsQualType
fnHsQualType
renderFnHsTypeWithNames :: FnHsType -> String
renderFnHsTypeWithNames :: FnHsType -> String
renderFnHsTypeWithNames FnHsType
fnHsType =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
renderedContextStrs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
renderedParamStrs
where HsQualType HsContext
assts HsType
unqualType = FnHsType -> HsQualType
fnHsQualType FnHsType
fnHsType
paramNameMaybes :: [Maybe String]
paramNameMaybes = FnHsType -> [Maybe String]
fnHsParamNameMaybes FnHsType
fnHsType
renderedContextStrs :: [String]
renderedContextStrs :: [String]
renderedContextStrs =
if HsContext -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsContext
assts
then []
else String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " (((HsQName, [HsType]) -> String) -> HsContext -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (HsQName, [HsType]) -> String
renderAsst HsContext
assts) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
") => "]
renderAsst :: (HsQName, [HsType]) -> String
renderAsst :: (HsQName, [HsType]) -> String
renderAsst (HsQName, [HsType])
asst = case (HsQName, [HsType])
asst of
(UnQual (HsIdent String
typeclass), [HsTyVar (HsIdent String
typeVar)]) ->
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
typeclass, String
" ", String
typeVar]
(HsQName, [HsType])
_ -> ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"renderAsst: Unexpected argument: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (HsQName, [HsType]) -> String
forall a. Show a => a -> String
show (HsQName, [HsType])
asst
renderedParamStrs :: [String]
renderedParamStrs :: [String]
renderedParamStrs = HsType -> [Maybe String] -> [String]
renderParams HsType
unqualType [Maybe String]
paramNameMaybes
renderParams :: HsType -> [Maybe String] -> [String]
renderParams :: HsType -> [Maybe String] -> [String]
renderParams HsType
fnType' [Maybe String]
paramNameMaybes' = case (HsType
fnType', [Maybe String]
paramNameMaybes') of
(HsTyFun HsType
a HsType
b, (Just String
name):[Maybe String]
restNames) ->
String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
") {- ^ " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
" -} -> " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsType -> [Maybe String] -> [String]
renderParams HsType
b [Maybe String]
restNames
(HsTyFun HsType
a HsType
b, Maybe String
Nothing:[Maybe String]
restNames) ->
String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
") -> " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsType -> [Maybe String] -> [String]
renderParams HsType
b [Maybe String]
restNames
(HsType, [Maybe String])
_ -> String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
fnType' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String
")"]