-- This file is part of Hoppy.
--
-- Copyright 2015-2024 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE ViewPatterns #-}

-- | Interface for defining bindings to C++ functions.
module Foreign.Hoppy.Generator.Spec.Function (
  -- * Data type
  Function, fnT, fnT',
  -- * Construction
  makeFn,
  -- * Properties
  fnExtName,
  fnCName,
  fnPurity,
  fnParams,
  fnReturn,
  fnReqs,
  fnAddendum,
  fnExceptionHandlers,
  -- * Code generators
  CallDirection (..),
  -- ** C++ generator
  CppCallType (..),
  sayCppArgRead,
  sayCppArgNames,
  -- * Internal
  -- ** C++ generator
  sayCppExportFn,
  -- ** Haskell generator
  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),
  )

-- | A C++ function declaration.
--
-- Use this data type's 'HasReqs' instance to make the function accessible.  You
-- do not need to add requirements for parameter or return types.
data Function = Function
  { Function -> FnName Identifier
fnCName :: FnName Identifier
    -- ^ The identifier used to call the function.
  , Function -> ExtName
fnExtName :: ExtName
    -- ^ The function's external name.
  , Function -> Purity
fnPurity :: Purity
    -- ^ Whether the function is pure.
  , Function -> [Parameter]
fnParams :: [Parameter]
    -- ^ The function's parameters.
  , Function -> Type
fnReturn :: Type
    -- ^ The function's return type.
  , Function -> Reqs
fnReqs :: Reqs
    -- ^ Requirements for bindings to access this function.
  , Function -> ExceptionHandlers
fnExceptionHandlers :: ExceptionHandlers
    -- ^ Exceptions that the function might throw.
  , Function -> Addendum
fnAddendum :: Addendum
    -- ^ The function's 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 -> ErrorMsg
show Function
fn =
    [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"<Function ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Function -> ExtName
fnExtName Function
fn), ErrorMsg
" ", FnName Identifier -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Function -> FnName Identifier
fnCName Function
fn),
            [Parameter] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Function -> [Parameter]
fnParams Function
fn), ErrorMsg
" ", Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Function -> Type
fnReturn Function
fn), ErrorMsg
">"]

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 }

instance HasAddendum Function where
  getAddendum :: Function -> Addendum
getAddendum = Function -> Addendum
fnAddendum
  setAddendum :: Addendum -> Function -> Function
setAddendum Addendum
addendum Function
fn = Function
fn { fnAddendum = 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 = f $ fnExceptionHandlers fn }

-- | Creates a binding for a C++ function.
makeFn :: (IsFnName Identifier name, IsParameter p)
       => name
       -> Maybe ExtName
       -- ^ An optional external name; will be automatically derived from
       -- the identifier if absent.
       -> Purity
       -> [p]  -- ^ Parameter types.
       -> Type  -- ^ Return type.
       -> Function
makeFn :: forall name p.
(IsFnName Identifier name, IsParameter p) =>
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

-- | A function taking parameters and returning a value (or 'voidT').  Function
-- pointers must wrap a 'fnT' in a 'ptrT'.
--
-- See also 'fnT'' which accepts parameter information.
fnT :: [Type] -> Type -> Type
-- (Keep docs in sync with hs-boot.)
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

-- | A version of 'fnT' that accepts additional information about parameters.
fnT' :: [Parameter] -> Type -> Type
-- (Keep docs in sync with hs-boot.)
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 a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
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  -- Render the body.

-- | The direction between languages in which a value is being passed.
data CallDirection =
  ToCpp  -- ^ Haskell code is calling out to C++.
  | FromCpp  -- ^ C++ is invoking a callback.
  deriving (Int -> CallDirection -> ShowS
[CallDirection] -> ShowS
CallDirection -> ErrorMsg
(Int -> CallDirection -> ShowS)
-> (CallDirection -> ErrorMsg)
-> ([CallDirection] -> ShowS)
-> Show CallDirection
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CallDirection -> ShowS
showsPrec :: Int -> CallDirection -> ShowS
$cshow :: CallDirection -> ErrorMsg
show :: CallDirection -> ErrorMsg
$cshowList :: [CallDirection] -> ShowS
showList :: [CallDirection] -> ShowS
Show)

-- | The name of a function to call.
data CppCallType =
    CallOp Operator
    -- ^ A call to the given operator, for example @x++@, @x * y@, @a[i]@.
  | CallFn (LC.Generator ())
    -- ^ A call to the function whose name is emitted by the given action.
  | VarRead (LC.Generator ())
    -- ^ Not a function call, but a read from a variable whose name is emitted
    -- by the given action.
  | VarWrite (LC.Generator ())
    -- ^ Not a function call, but a write to a variable whose name is emitted by
    -- the given action.

-- | Generates a C++ wrapper function for calling a C++ function (or method, or
-- reading from or writing to a variable).  The generated function handles
-- C++-side marshalling of values and propagating exceptions as requested.
--
-- See also 'sayHsExportFn'.
sayCppExportFn ::
     ExtName  -- ^ The external name of the function.
  -> CppCallType  -- ^ The C++ name at which the function can be invoked.
  -> Maybe Type
     -- ^ If present, then we are wrapping a method within some class, and the
     -- type is that of the class.
  -> [Parameter]  -- ^ Info about the function's parameters.
  -> Type  -- ^ The function's return type.
  -> ExceptionHandlers
     -- ^ Exception handlers configured on the function itself.  No need to call
     -- 'LC.getEffectiveExceptionHandlers' to combine the function's handlers
     -- with those from the module and interface; this function does that already.
  -> Bool
     -- ^ Whether to generate the function definition.  If false, only the
     -- declaration is generated (no function body).
  -> 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 ErrorMsg)) ExceptionHandlers
-> ReaderT
     Env (WriterT [Chunk] (Either ErrorMsg)) [ExceptionHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptionHandlers
-> ReaderT
     Env (WriterT [Chunk] (Either ErrorMsg)) 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExceptionHandler]
handlerList
      addExceptionParamNames :: [ErrorMsg] -> [ErrorMsg]
addExceptionParamNames =
        if Bool
catches then ([ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg
LC.exceptionIdArgName, ErrorMsg
LC.exceptionPtrArgName]) else [ErrorMsg] -> [ErrorMsg]
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
paramTypes
  [Maybe Type]
paramCTypeMaybes <- (Type
 -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type))
-> [Type]
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (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 ErrorMsg)) (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 ErrorMsg)) [Reqs]
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs)
-> [Type] -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Reqs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
LC.typeReqs (Type
retTypeType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
paramTypes)

  ErrorMsg
-> [ErrorMsg] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (ExtName -> ErrorMsg
LC.externalNameToCpp ExtName
extName)
                 (([ErrorMsg] -> [ErrorMsg])
-> (Type -> [ErrorMsg] -> [ErrorMsg])
-> Maybe Type
-> [ErrorMsg]
-> [ErrorMsg]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [ErrorMsg] -> [ErrorMsg]
forall a. a -> a
id (([ErrorMsg] -> [ErrorMsg]) -> Type -> [ErrorMsg] -> [ErrorMsg]
forall a b. a -> b -> a
const (ErrorMsg
"self"ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:)) Maybe Type
maybeThisType ([ErrorMsg] -> [ErrorMsg]) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$
                  [ErrorMsg] -> [ErrorMsg]
addExceptionParamNames ([ErrorMsg] -> [ErrorMsg]) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$
                  (Type -> Maybe Type -> Int -> ErrorMsg)
-> [Type] -> [Maybe Type] -> [Int] -> [ErrorMsg]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\Type
pt Maybe Type
ctm ->
                              -- TManual needs special handling to determine whether a
                              -- conversion is necessary.  'typeToCType' doesn't suffice
                              -- because for TManual this check relies on the direction of
                              -- the call.  See the special case in 'sayCppArgRead' as
                              -- well.
                              let hasConversion :: Bool
hasConversion = case Type
pt of
                                    Internal_TManual ConversionSpec
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 -> ErrorMsg
LC.toArgNameAlt else Int -> ErrorMsg
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
        ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"try {\n"
        [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"*", ErrorMsg
LC.exceptionIdArgName, ErrorMsg
" = 0;\n"]

      -- Convert arguments that aren't passed in directly.
      ((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 -- Determines how to call the exported function or method.
          sayCall :: Generator ()
sayCall = case CppCallType
callType of
            CallOp Operator
op -> do
              ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"("
              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 :: [ErrorMsg]
paramNames@(ErrorMsg
p1:ErrorMsg
p2:[ErrorMsg]
_) = (if Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType then (ErrorMsg
"(*self)"ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:) else [ErrorMsg] -> [ErrorMsg]
forall a. a -> a
id) ([ErrorMsg] -> [ErrorMsg]) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$
                                         (Int -> ErrorMsg) -> [Int] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ErrorMsg
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
$ ErrorMsg -> Generator ()
forall a. ErrorMsg -> Generator a
LC.abort (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ErrorMsg
"sayCppExportFn: Operator ", Operator -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Operator
op, ErrorMsg
" for export ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ExtName
extName,
                     ErrorMsg
" requires ", Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Int
n, ErrorMsg
" parameter(s), but has ", Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Int
effectiveParamCount,
                     ErrorMsg
"."]
              case HasCallStack => Operator -> OperatorType
Operator -> OperatorType
operatorType Operator
op of
                UnaryPrefixOperator ErrorMsg
symbol -> Int -> Generator ()
assertParamCount Int
1 Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
symbol, ErrorMsg
p1]
                UnaryPostfixOperator ErrorMsg
symbol -> Int -> Generator ()
assertParamCount Int
1 Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
p1, ErrorMsg
symbol]
                BinaryOperator ErrorMsg
symbol -> Int -> Generator ()
assertParamCount Int
2 Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
p1, ErrorMsg
symbol, ErrorMsg
p2]
                OperatorType
CallOperator ->
                  [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg
p1 ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
"(" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: Int -> [ErrorMsg] -> [ErrorMsg]
forall a. Int -> [a] -> [a]
take (Int
effectiveParamCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> [ErrorMsg] -> [ErrorMsg]
forall a. Int -> [a] -> [a]
drop Int
1 [ErrorMsg]
paramNames) [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg
")"]
                OperatorType
ArrayOperator -> Int -> Generator ()
assertParamCount Int
2 Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
p1, ErrorMsg
"[", ErrorMsg
p2, ErrorMsg
"]"]
              ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
")"
            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
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"self->"
              Generator ()
sayCppName
              ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"("
              Int -> Generator ()
sayCppArgNames Int
paramCount
              ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
")"
            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
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"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
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"self->"
              Generator ()
sayVarName
              [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
" = ", Int -> ErrorMsg
LC.toArgName Int
1]

          -- Writes the call, transforming the return value if necessary.
          -- These translations should be kept in sync with typeToCType.
          sayCallAndReturn :: Type -> Maybe Type -> Generator ()
sayCallAndReturn Type
retType' Maybe Type
retCTypeMaybe' = case (Type
retType', Maybe Type
retCTypeMaybe') of
            -- Void needs special handling because we don't want a return statement.
            (Type
Internal_TVoid, Maybe Type
Nothing) -> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"

            -- Custom conversions.
            (Internal_TManual ConversionSpec
s, Maybe Type
_) -> do
              -- The ConversionSpec s may or may not specify an intermediate
              -- type to pass over the FFI boundary: the second value in the
              -- pair (we check this before the (_, Nothing) case below).  We
              -- don't actually care what it is though, because s already
              -- specifies how to convert.
              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
                -- If there is a custom conversion expression defined, use it.
                Just Generator () -> Maybe (Generator ()) -> Generator ()
convFn -> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
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 a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
                -- Otherwise, assume we can just return the value directly.
                Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
Nothing -> Generator ()
sayCallAndReturnDirect

            -- The case of a value for which no conversion is necessary.
            (Type
_, Maybe Type
Nothing) -> Generator ()
sayCallAndReturnDirect

            -- Object cases.
            (Internal_TRef Type
cls, Just (Internal_TPtr Type
cls')) | Type
cls Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
cls' ->
              ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return &(" Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
");\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 -> ErrorMsg -> Generator ()
forall a. ErrorMsg -> Generator a
LC.abort (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"sayCppExportFn: Unexpected return types ", (Type, Maybe Type) -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Type, Maybe Type)
ts,
                                     ErrorMsg
" while generating binding for ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ExtName
extName, ErrorMsg
"."]

          sayCallAndReturnDirect :: Generator ()
sayCallAndReturnDirect = ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\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 ErrorMsg)) 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
          ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"} catch ("
          case ExceptionHandler
handler of
            CatchClass Class
cls -> ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
LC.exceptionVarName Maybe [ErrorMsg]
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 -> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"..."
          ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
") {\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 ErrorMsg)) ExceptionId
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ExceptionId
exceptionId
              Maybe ExceptionId
Nothing -> ErrorMsg
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
forall a. ErrorMsg -> Generator a
LC.abort (ErrorMsg
 -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId)
-> ErrorMsg
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                         [ErrorMsg
"sayCppExportFn: Trying to catch non-exception class ", Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
cls,
                          ErrorMsg
" while generating binding for ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ExtName
extName, ErrorMsg
"."]
            ExceptionHandler
CatchAll -> ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ExceptionId
exceptionCatchAllId
          [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"*", ErrorMsg
LC.exceptionIdArgName, ErrorMsg
" = ", Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Int -> ErrorMsg) -> Int -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
exceptionId, ErrorMsg
";\n"]

          case ExceptionHandler
handler of
            ExceptionHandler
CatchAll -> [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"*", ErrorMsg
LC.exceptionPtrArgName, ErrorMsg
" = 0;\n"]
            CatchClass Class
cls -> do
              -- Object pointers don't convert automatically to void*.
              [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"*", ErrorMsg
LC.exceptionPtrArgName, ErrorMsg
" = reinterpret_cast<void*>(new "]
              Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [ErrorMsg] -> Type -> m ()
LC.sayType Maybe [ErrorMsg]
forall a. Maybe a
Nothing (Type -> Generator ()) -> Type -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls
              [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"(", ErrorMsg
LC.exceptionVarName, ErrorMsg
"));\n"]

          -- For all of the types our gateway functions actually return, "return
          -- 0" is a valid statement.
          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
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return 0;\n"

        ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"}\n"

  where sayReturnNew :: Class -> m a -> m ()
sayReturnNew Class
cls m a
sayCall =
          ErrorMsg -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return new" m () -> m () -> m ()
forall a b. m a -> m b -> m b
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 a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"(" m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          m a
sayCall m a -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
");\n"

-- | Generates code to marshal a value between a C++ type and the intermediate
-- type to be used over the FFI.  If @dir@ is 'ToCpp', then we are a C++
-- function reading an argument from foreign code.  If @dir@ is 'FromCpp', then
-- we are invoking a foreign callback.
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
    -- Assert that all types referred to in a function pointer type are all
    -- representable as C types.
    let paramTypes :: [Type]
paramTypes = (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType [Parameter]
params
        check :: ErrorMsg
-> Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe ErrorMsg)
check ErrorMsg
label Type
t' = ((ErrorMsg
label ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
t') ErrorMsg -> Maybe Type -> Maybe ErrorMsg
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Maybe Type -> Maybe ErrorMsg)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe ErrorMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type)
LC.typeToCType Type
t'
    [ErrorMsg]
mismatches <-
      ([Maybe ErrorMsg] -> [ErrorMsg])
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe ErrorMsg]
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [ErrorMsg]
forall a b.
(a -> b)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe ErrorMsg] -> [ErrorMsg]
forall a. [Maybe a] -> [a]
catMaybes (ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe ErrorMsg]
 -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [ErrorMsg])
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe ErrorMsg]
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [ErrorMsg]
forall a b. (a -> b) -> a -> b
$
      (:) (Maybe ErrorMsg -> [Maybe ErrorMsg] -> [Maybe ErrorMsg])
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe ErrorMsg)
-> ReaderT
     Env
     (WriterT [Chunk] (Either ErrorMsg))
     ([Maybe ErrorMsg] -> [Maybe ErrorMsg])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorMsg
-> Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe ErrorMsg)
check ErrorMsg
"return type" Type
retType
          ReaderT
  Env
  (WriterT [Chunk] (Either ErrorMsg))
  ([Maybe ErrorMsg] -> [Maybe ErrorMsg])
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe ErrorMsg]
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe ErrorMsg]
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (a -> b)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type
 -> ReaderT
      Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe ErrorMsg))
-> [Type]
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe ErrorMsg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Type
paramType -> ErrorMsg
-> Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe ErrorMsg)
check ErrorMsg
"parameter" Type
paramType) [Type]
paramTypes
    Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ErrorMsg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMsg]
mismatches) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      ErrorMsg -> Generator ()
forall a. ErrorMsg -> Generator a
LC.abort (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ErrorMsg] -> ErrorMsg) -> [ErrorMsg] -> ErrorMsg
forall a b. (a -> b) -> a -> b
$
      ErrorMsg
"sayCppArgRead: Some types within a function pointer type use non-C types, " ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
      ErrorMsg
"but only C types may be used.  The unsupported types are: " ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
      ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
intersperse ErrorMsg
"; " [ErrorMsg]
mismatches [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg
".  The whole function type is ", Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
t, ErrorMsg
"."]

    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 -> ErrorMsg -> Generator ()
forall a. HasCallStack => ErrorMsg -> a
error (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> Class -> ErrorMsg
objToHeapTWrongDirectionErrorMsg (ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
"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
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"* ", Int -> ErrorMsg
LC.toArgName Int
n, ErrorMsg
" = 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
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"(", Int -> ErrorMsg
LC.toArgNameAlt Int
n, ErrorMsg
");\n"]

  Internal_TToGc Type
t' -> case CallDirection
dir of
    CallDirection
ToCpp -> ErrorMsg -> Generator ()
forall a. HasCallStack => ErrorMsg -> a
error (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> Type -> ErrorMsg
toGcTWrongDirectionErrorMsg (ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
"sayCppArgRead") Type
t'
    CallDirection
FromCpp -> do
      let newCppType :: Type
newCppType = case Type
t' of
            -- In the case of (TToGc (TObj _)), we copy the temporary object to
            -- the heap and let the foreign language manage that value.
            Internal_TObj Class
cls -> Class -> Type
objToHeapT Class
cls
            Type
_ -> Type
t'
      Maybe Type
cType <- Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type)
LC.typeToCType Type
newCppType
      CallDirection -> (Int, Type, Maybe Type) -> Generator ()
sayCppArgRead CallDirection
dir (Int
n, Type
newCppType, Maybe Type
cType)

  -- In case of a manual type, apply the custom conversion, if there is one.
  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 (ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Int -> ErrorMsg
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
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Int -> ErrorMsg
LC.toArgName Int
n)

  Type
_ -> Generator ()
convertDefault

  where -- Primitive types don't need to be encoded/decoded.  But if maybeCType is a
        -- Just, then we're expected to do some encoding/decoding, so something is
        -- wrong.
        --
        -- TODO Do we need to handle TConst?
        convertDefault :: Generator ()
convertDefault = Maybe Type
-> (Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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 ErrorMsg)) Any)
 -> Generator ())
-> (Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Any)
-> Generator ()
forall a b. (a -> b) -> a -> b
$ \Type
cType ->
          ErrorMsg -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Any
forall a. ErrorMsg -> Generator a
LC.abort (ErrorMsg -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Any)
-> ErrorMsg -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Any
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ErrorMsg
"sayCppArgRead: Don't know how to convert ", CallDirection -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show CallDirection
dir, ErrorMsg
" between C-type ", Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
cType,
           ErrorMsg
" and C++-type ", Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
cppType, ErrorMsg
"."]

        convertObj :: Type -> m ()
convertObj Type
cppType' = case CallDirection
dir of
          CallDirection
ToCpp -> do
            ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar (Int -> ErrorMsg
LC.toArgName Int
n) Maybe [ErrorMsg]
forall a. Maybe a
Nothing (Type -> m ()) -> Type -> m ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
refT Type
cppType'
            [ErrorMsg] -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
" = *", Int -> ErrorMsg
LC.toArgNameAlt Int
n, ErrorMsg
";\n"]
          CallDirection
FromCpp -> do
            ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar (Int -> ErrorMsg
LC.toArgName Int
n) Maybe [ErrorMsg]
forall a. Maybe a
Nothing (Type -> m ()) -> Type -> m ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT Type
cppType'
            [ErrorMsg] -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
" = &", Int -> ErrorMsg
LC.toArgNameAlt Int
n, ErrorMsg
";\n"]

-- | Prints a comma-separated list of the argument names used for C++ gateway
-- functions.  The number specifies how many names to print.
sayCppArgNames :: Int -> LC.Generator ()
sayCppArgNames :: Int -> Generator ()
sayCppArgNames Int
count =
  [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
intersperse ErrorMsg
", " ([ErrorMsg] -> [ErrorMsg]) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ (Int -> ErrorMsg) -> [Int] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ErrorMsg
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 a b.
(Function -> a -> b) -> (Function -> a) -> Function -> b
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 a b.
(Function -> a -> b) -> (Function -> a) -> Function -> b
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 a b.
(Function -> a -> b) -> (Function -> a) -> Function -> b
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 a b.
(Function -> a -> b) -> (Function -> a) -> Function -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> Type
fnReturn (Function -> ExceptionHandlers -> Generator ())
-> (Function -> ExceptionHandlers) -> Function -> Generator ()
forall a b.
(Function -> a -> b) -> (Function -> a) -> Function -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> ExceptionHandlers
fnExceptionHandlers) Function
fn

-- | Generates a Haskell wrapper function for calling a C++ function (or method,
-- or reading from or writing to a variable, as with 'sayCppExportFn').  The
-- generated function handles Haskell-side marshalling of values and propagating
-- exceptions as requested.
sayHsExportFn ::
     LH.SayExportMode  -- ^ The phase of code generation.
  -> ExtName
     -- ^ The external name for the entity we're generating.  For class
     -- entities, this will include the class's external name as a prefix.
  -> ExtName
     -- ^ An alternate external name to use to generate Haskell function names.
     -- For non-class entities, this can be just the regular external name.  For
     -- class entities, in order to strip off the class name that was added so
     -- that the entity's external name is unique, this can just be the name of
     -- the function, variable, etc.
  -> Purity  -- ^ Whether or not the function is pure (free of side effects).
  -> [Parameter]  -- ^ Parameter info.
  -> Type  -- ^ The return type.
  -> ExceptionHandlers
     -- ^ Any exception handlers to apply to the binding, in addition to what
     -- its module and interface provide.
  -> 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 a. [a] -> 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

  -- We use the pure version of toHsFnName here; because foreignName isn't an
  -- ExtName present in the interface's lookup table, toHsFnName would bail on
  -- it.  Since functions don't reference each other (e.g. we don't put anything
  -- in .hs-boot files for them in circular modules cases), this isn't a problem.
  let hsFnName :: ErrorMsg
hsFnName = ExtName -> ErrorMsg
LH.toHsFnName' ExtName
foreignName
      hsFnImportedName :: ErrorMsg
hsFnImportedName = ErrorMsg
hsFnName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"'"

  case SayExportMode
mode of
    SayExportMode
LH.SayExportForeignImports ->
      ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext (ErrorMsg
"generating imports for function " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ExtName
extName) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        -- Print a "foreign import" statement.
        FnHsType
hsCType <- HsTypeSide
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator FnHsType
fnToHsTypeAndUse HsTypeSide
LH.HsCSide Purity
purity [Parameter]
params Type
retType ExceptionHandlers
effectiveHandlers
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"foreign import ccall \"", ExtName -> ErrorMsg
LC.externalNameToCpp ExtName
extName, ErrorMsg
"\" ", ErrorMsg
hsFnImportedName,
                    ErrorMsg
" :: ", FnHsType -> ErrorMsg
renderFnHsType FnHsType
hsCType]

    SayExportMode
LH.SayExportDecls -> ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext (ErrorMsg
"generating function " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ExtName
extName) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
      -- Print the type signature.
      Generator ()
LH.ln
      ErrorMsg -> Generator ()
LH.addExport ErrorMsg
hsFnName
      FnHsType
hsHsType <- HsTypeSide
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator FnHsType
fnToHsTypeAndUse HsTypeSide
LH.HsHsSide Purity
purity [Parameter]
params Type
retType ExceptionHandlers
effectiveHandlers
      [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsFnName, ErrorMsg
" :: ", FnHsType -> ErrorMsg
renderFnHsTypeWithNames FnHsType
hsHsType]

      case Purity
purity of
        Purity
Nonpure -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Purity
Pure -> [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"{-# NOINLINE ", ErrorMsg
hsFnName, ErrorMsg
" #-}"]

      -- Print the function body.
      let argNames :: [ErrorMsg]
argNames = (Int -> ErrorMsg) -> [Int] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ErrorMsg
LH.toArgName [Int
1..[Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
paramTypes]
          convertedArgNames :: [ErrorMsg]
convertedArgNames = ShowS -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"'") [ErrorMsg]
argNames
      -- Operators on this line must bind more weakly than operators used below,
      -- namely ($) and (>>=).  (So finish the line with ($).)
      [ErrorMsg]
lineEnd <- case Purity
purity of
        Purity
Nonpure -> [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg
" ="]
        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 [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)", HsImportSet
hsImportForUnsafeIO]
                   [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg
" = HoppySIU.unsafePerformIO $"]
      [ErrorMsg] -> Generator ()
LH.saysLn ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg
hsFnName ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ShowS -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) [ErrorMsg]
argNames [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
lineEnd
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        [(Type, ErrorMsg, ErrorMsg)]
-> ((Type, ErrorMsg, ErrorMsg) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Type] -> [ErrorMsg] -> [ErrorMsg] -> [(Type, ErrorMsg, ErrorMsg)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Type]
paramTypes [ErrorMsg]
argNames [ErrorMsg]
convertedArgNames) (((Type, ErrorMsg, ErrorMsg) -> Generator ()) -> Generator ())
-> ((Type, ErrorMsg, ErrorMsg) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \(Type
t, ErrorMsg
argName, ErrorMsg
argName') ->
          CallDirection -> Type -> ErrorMsg -> ErrorMsg -> Generator ()
sayHsArgProcessing CallDirection
ToCpp Type
t ErrorMsg
argName ErrorMsg
argName'

        ErrorMsg
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
. ErrorMsg -> HsImportSet
hsWholeModuleImport (ErrorMsg -> HsImportSet)
-> (Module -> ErrorMsg) -> Module -> HsImportSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Module -> ErrorMsg
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 (ErrorMsg -> Generator Module
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                                ErrorMsg
"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 [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)", HsImportSet
hsImportForRuntime]
                  ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ErrorMsg
"HoppyFHR.internalHandleExceptions exceptionDb' $ "
          else ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ErrorMsg
""

        let callWords :: [ErrorMsg]
callWords = ErrorMsg
exceptionHandling ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
hsFnImportedName ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ShowS -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) [ErrorMsg]
convertedArgNames
        CallDirection -> Type -> [ErrorMsg] -> Generator ()
sayHsCallAndProcessReturn CallDirection
ToCpp Type
retType [ErrorMsg]
callWords

    SayExportMode
LH.SayExportBoot ->
      -- Functions (methods included) cannot be referenced from other exports,
      -- so we don't need to emit anything.
      --
      -- If this changes, revisit the comment on hsFnName above.
      () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Generates Haskell code to perform marshalling of a function's argument in a
-- specified direction.
--
-- This function either generates a line or lines such that subsequent lines can
-- refer to the output binding.  The final line is either terminated with
--
-- > ... $ \value ->
--
-- or
--
-- > let ... in
--
-- so that precedence is not an issue.
sayHsArgProcessing ::
     CallDirection  -- ^ The direction of the FFI call.
  -> Type  -- ^ The type of the value to be marshalled.
  -> String  -- ^ The name of the binding holding the input value.
  -> String  -- ^ The name of the binding to create for the output value.
  -> LH.Generator ()
sayHsArgProcessing :: CallDirection -> Type -> ErrorMsg -> ErrorMsg -> Generator ()
sayHsArgProcessing CallDirection
dir Type
t ErrorMsg
fromVar ErrorMsg
toVar =
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext (ErrorMsg
"processing argument of type " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
t) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
  case Type
t of
    Type
Internal_TVoid -> ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"TVoid is not a valid argument type"
    -- References and pointers are handled equivalently.
    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 [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)",
                                 HsImportSet
hsImportForRuntime]
        ErrorMsg
castMethodName <- Constness
-> Class -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsCastMethodName Constness
Nonconst Class
cls
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"HoppyFHR.withCppPtr (", ErrorMsg
castMethodName, ErrorMsg
" ", ErrorMsg
fromVar,
                   ErrorMsg
") $ \\", ErrorMsg
toVar, ErrorMsg
" ->"]
      CallDirection
FromCpp -> do
        ErrorMsg
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"let ", ErrorMsg
toVar, ErrorMsg
" = ", ErrorMsg
ctorName, ErrorMsg
" ", ErrorMsg
fromVar, ErrorMsg
" in"]
    Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> case CallDirection
dir of
      CallDirection
ToCpp -> do
        -- Same as the (TObj _), ToCpp case.
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)",
                                 HsImportSet
hsImportForPrelude,
                                 HsImportSet
hsImportForRuntime]
        ErrorMsg
withValuePtrName <- Class -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsWithValuePtrName Class
cls
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
withValuePtrName, ErrorMsg
" ", ErrorMsg
fromVar,
                   ErrorMsg
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", ErrorMsg
toVar, ErrorMsg
" ->"]
      CallDirection
FromCpp -> do
        ErrorMsg
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"let ", ErrorMsg
toVar, ErrorMsg
" = ", ErrorMsg
ctorName, ErrorMsg
" ", ErrorMsg
fromVar, ErrorMsg
" in"]
    Internal_TPtr Type
_ -> Generator ()
noConversion
    Internal_TRef Type
t' -> CallDirection -> Type -> ErrorMsg -> ErrorMsg -> Generator ()
sayHsArgProcessing CallDirection
dir (Type -> Type
ptrT Type
t') ErrorMsg
fromVar ErrorMsg
toVar
    Internal_TFn {} -> ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrorMsg
"TFn unimplemented"
    Internal_TObj Class
cls -> case CallDirection
dir of
      CallDirection
ToCpp -> do
        -- Same as the (TPtr (TConst (TObj _))), ToPtr case.
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)",
                                 HsImportSet
hsImportForPrelude,
                                 HsImportSet
hsImportForRuntime]
        ErrorMsg
withValuePtrName <- Class -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsWithValuePtrName Class
cls
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
withValuePtrName, ErrorMsg
" ", ErrorMsg
fromVar,
                ErrorMsg
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", ErrorMsg
toVar, ErrorMsg
" ->"]
      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 [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(>>=)",
                                   HsImportSet
hsImportForRuntime]
          ErrorMsg
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
          [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"HoppyFHR.decode (", ErrorMsg
ctorName, ErrorMsg
" ", ErrorMsg
fromVar, ErrorMsg
") >>= \\", ErrorMsg
toVar, ErrorMsg
" ->"]
        Maybe (Generator ())
Nothing ->
          ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ErrorMsg
"Can't pass a TObj of ", Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
cls,
           ErrorMsg
" from C++ to Haskell because no class decode conversion is defined"]
    Internal_TObjToHeap Class
cls -> case CallDirection
dir of
      CallDirection
ToCpp -> ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> Class -> ErrorMsg
objToHeapTWrongDirectionErrorMsg Maybe ErrorMsg
forall a. Maybe a
Nothing Class
cls
      CallDirection
FromCpp -> CallDirection -> Type -> ErrorMsg -> ErrorMsg -> Generator ()
sayHsArgProcessing CallDirection
dir (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) ErrorMsg
fromVar ErrorMsg
toVar
    Internal_TToGc Type
t' -> case CallDirection
dir of
      CallDirection
ToCpp -> ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> Type -> ErrorMsg
toGcTWrongDirectionErrorMsg Maybe ErrorMsg
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 [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(>>=)",
                                 HsImportSet
hsImportForRuntime]
        ErrorMsg
ctorName <-
          ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> (Class
    -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> Maybe Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> Type -> ErrorMsg
tToGcInvalidFormErrorMessage Maybe ErrorMsg
forall a. Maybe a
Nothing Type
t')
                (Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst) (Maybe Class
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> Maybe Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
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
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"HoppyFHR.toGc (", ErrorMsg
ctorName, ErrorMsg
" ", ErrorMsg
fromVar, ErrorMsg
") >>= \\", ErrorMsg
toVar, ErrorMsg
" ->"]
    Internal_TConst Type
t' -> CallDirection -> Type -> ErrorMsg -> ErrorMsg -> Generator ()
sayHsArgProcessing CallDirection
dir Type
t' ErrorMsg
fromVar ErrorMsg
toVar

    Internal_TManual ConversionSpec
s -> do
      let maybeGen :: Maybe (ConversionMethod (Generator ()))
maybeGen =
            (ConversionSpecHaskell -> ConversionMethod (Generator ()))
-> Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ()))
forall a b. (a -> b) -> Maybe a -> Maybe b
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 ErrorMsg)) a
throwForNoConversion =
            ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a)
-> ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ErrorMsg
"No conversion defined for ", ConversionSpec -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ConversionSpec
s,
             case CallDirection
dir of
               CallDirection
ToCpp -> ErrorMsg
" to C++ from Haskell"
               CallDirection
FromCpp -> ErrorMsg
" 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
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(>>=)"
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"("
          Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent Generator ()
gen
          [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
") ", ErrorMsg
fromVar, ErrorMsg
" >>= \\", ErrorMsg
toVar, ErrorMsg
" ->"]
        Just ConversionMethod (Generator ())
BinaryCompatible -> [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"let ", ErrorMsg
toVar, ErrorMsg
" = ", ErrorMsg
fromVar, ErrorMsg
" in"]
        Just ConversionMethod (Generator ())
ConversionUnsupported -> Generator ()
forall {a}. ReaderT Env (WriterT Output (Except ErrorMsg)) a
throwForNoConversion
        Maybe (ConversionMethod (Generator ()))
Nothing -> Generator ()
forall {a}. ReaderT Env (WriterT Output (Except ErrorMsg)) a
throwForNoConversion

  where noConversion :: Generator ()
noConversion = [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"let ", ErrorMsg
toVar, ErrorMsg
" = ", ErrorMsg
fromVar, ErrorMsg
" in"]

-- | Note that the 'CallDirection' is the direction of the call, not the
-- direction of the return.  'ToCpp' means we're returning to the foreign
-- language, 'FromCpp' means we're returning from it.
sayHsCallAndProcessReturn :: CallDirection -> Type -> [String] -> LH.Generator ()
sayHsCallAndProcessReturn :: CallDirection -> Type -> [ErrorMsg] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t [ErrorMsg]
callWords =
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext (ErrorMsg
"processing return value of type " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
t) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
  case Type
t of
    Type
Internal_TVoid -> Generator ()
sayCall
    -- The same as TPtr (TConst (TObj _)), but nonconst.
    Internal_TPtr (Internal_TObj Class
cls) -> do
      case CallDirection
dir of
        CallDirection
ToCpp -> do
          HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
          ErrorMsg
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
          [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"HoppyP.fmap ", ErrorMsg
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]
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"HoppyP.fmap HoppyFHR.toPtr"
          Generator ()
sayCall
    -- The same as TPtr (TConst (TObj _)), but nonconst.
    Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> case CallDirection
dir of
      CallDirection
ToCpp -> do
        HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
        ErrorMsg
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"HoppyP.fmap ", ErrorMsg
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]
        ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"HoppyP.fmap HoppyFHR.toPtr"
        Generator ()
sayCall
    Internal_TPtr Type
_ -> Generator ()
sayCall
    Internal_TRef Type
t' -> CallDirection -> Type -> [ErrorMsg] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT Type
t') [ErrorMsg]
callWords
    Internal_TFn {} -> ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ErrorMsg
"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 [ErrorMsg -> [ErrorMsg] -> HsImportSet
hsImports ErrorMsg
"Prelude" [ErrorMsg
"(.)", ErrorMsg
"(=<<)"],
                                   HsImportSet
hsImportForRuntime]
          ErrorMsg
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
          [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"(HoppyFHR.decodeAndDelete . ", ErrorMsg
ctorName, ErrorMsg
") =<<"]
          Generator ()
sayCall
        Maybe (Generator ())
Nothing ->
          ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ErrorMsg
"Can't return a TObj of ", Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
cls,
           ErrorMsg
" 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 [ErrorMsg -> [ErrorMsg] -> HsImportSet
hsImports ErrorMsg
"Prelude" [ErrorMsg
"(.)", ErrorMsg
"(=<<)"],
                                 HsImportSet
hsImportForPrelude,
                                 HsImportSet
hsImportForRuntime]
        ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<"
        Generator ()
sayCall
    Internal_TObjToHeap Class
cls -> case CallDirection
dir of
      CallDirection
ToCpp -> CallDirection -> Type -> [ErrorMsg] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) [ErrorMsg]
callWords
      CallDirection
FromCpp -> ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> Class -> ErrorMsg
objToHeapTWrongDirectionErrorMsg Maybe ErrorMsg
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 [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(=<<)",
                                 HsImportSet
hsImportForRuntime]
        ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"HoppyFHR.toGc =<<"
        -- TToGc (TObj _) should create a pointer rather than decoding, so we
        -- change the TObj _ into a TPtr (TObj _).
        case Type
t' of
          Internal_TObj Class
_ -> CallDirection -> Type -> [ErrorMsg] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT Type
t') [ErrorMsg]
callWords
          Type
_ -> CallDirection -> Type -> [ErrorMsg] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t' [ErrorMsg]
callWords
      CallDirection
FromCpp -> ErrorMsg -> Generator ()
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe ErrorMsg -> Type -> ErrorMsg
toGcTWrongDirectionErrorMsg Maybe ErrorMsg
forall a. Maybe a
Nothing Type
t'
    Internal_TConst Type
t' -> CallDirection -> Type -> [ErrorMsg] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t' [ErrorMsg]
callWords

    Internal_TManual ConversionSpec
s -> do
      -- Remember 'dir' is backward here, because we're dealing with a return
      -- value, so these functions look backward.
      let maybeGen :: Maybe (ConversionMethod (Generator ()))
maybeGen =
            (ConversionSpecHaskell -> ConversionMethod (Generator ()))
-> Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ()))
forall a b. (a -> b) -> Maybe a -> Maybe b
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 ErrorMsg)) a
throwForNoConversion =
            ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a)
-> ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ErrorMsg
"No conversion defined for ", ConversionSpec -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show ConversionSpec
s,
             case CallDirection
dir of
               CallDirection
ToCpp -> ErrorMsg
" from C++ to Haskell"
               CallDirection
FromCpp -> ErrorMsg
" 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
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(=<<)"
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"("
          Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent Generator ()
gen
          ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
") =<<"
        Just ConversionMethod (Generator ())
BinaryCompatible -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ConversionMethod (Generator ())
ConversionUnsupported -> Generator ()
forall {a}. ReaderT Env (WriterT Output (Except ErrorMsg)) a
throwForNoConversion
        Maybe (ConversionMethod (Generator ()))
Nothing -> Generator ()
forall {a}. ReaderT Env (WriterT Output (Except ErrorMsg)) a
throwForNoConversion
      Generator ()
sayCall

  where sayCall :: Generator ()
sayCall = [ErrorMsg] -> Generator ()
LH.saysLn ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"(" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: [ErrorMsg]
callWords [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg
")"]

-- | The Haskell type of a 'Function', as computed by 'fnToHsTypeAndUse'.  This
-- combines a 'HsQualType' with a list of parameter names.
data FnHsType = FnHsType
  { FnHsType -> HsQualType
fnHsQualType :: HsQualType
  , FnHsType -> [Maybe ErrorMsg]
fnHsParamNameMaybes :: [Maybe String]
  }

-- | Implements special logic on top of 'LH.cppTypeToHsTypeAndUse', that
-- computes the Haskell __qualified__ type for a function, including typeclass
-- constraints, and bundles it with parameter names.
fnToHsTypeAndUse ::
     LH.HsTypeSide
  -> Purity
  -> [Parameter]
  -> Type
  -> ExceptionHandlers
     -- ^ These should be the effective exception handlers for the function, as
     -- returned by
     -- @'LH.getEffectiveExceptionHandlers' . 'fnExceptionHandlers'@,
     -- not just the function's exception handlers directly from
     -- @fnExceptionHandlers@.
  -> 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 a. [a] -> 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 ErrorMsg]
paramNameMaybes =
        (if Bool
getsExcParams then ([Maybe ErrorMsg] -> [Maybe ErrorMsg] -> [Maybe ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
"excId", ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
"excPtr"]) else [Maybe ErrorMsg] -> [Maybe ErrorMsg]
forall a. a -> a
id) ([Maybe ErrorMsg] -> [Maybe ErrorMsg])
-> [Maybe ErrorMsg] -> [Maybe ErrorMsg]
forall a b. (a -> b) -> a -> b
$
        (Parameter -> Maybe ErrorMsg) -> [Parameter] -> [Maybe ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Maybe ErrorMsg
parameterName [Parameter]
params

      defaultParamNames :: [ErrorMsg]
defaultParamNames = (Int -> ErrorMsg) -> [Int] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ErrorMsg
LH.toArgName [Int
1..]

      defaultedParamNames :: [ErrorMsg]
defaultedParamNames = (ErrorMsg -> Maybe ErrorMsg -> ErrorMsg)
-> [ErrorMsg] -> [Maybe ErrorMsg] -> [ErrorMsg]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ErrorMsg -> Maybe ErrorMsg -> ErrorMsg
forall a. a -> Maybe a -> a
fromMaybe [ErrorMsg]
defaultParamNames [Maybe ErrorMsg]
paramNameMaybes

  [HsQualType]
paramQualTypes <- ((ErrorMsg, Type)
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType)
-> [(ErrorMsg, Type)]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [HsQualType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ErrorMsg, Type)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
contextForParam ([(ErrorMsg, Type)]
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) [HsQualType])
-> [(ErrorMsg, Type)]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [HsQualType]
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> [Type] -> [(ErrorMsg, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ErrorMsg]
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

  -- Determine the 'HsHsSide' return type for the function.  Do the conversion
  -- to a Haskell type, and wrap the result in 'IO' if the function is impure.
  -- (HsCSide types always get wrapped in IO.)
  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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsType
hsReturnInitial
    (Purity, HsTypeSide)
_ -> do
      HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
      HsType -> Generator HsType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"HoppyP.IO") HsType
hsReturnInitial

  FnHsType -> Generator FnHsType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsType -> HsType -> HsType
HsTyFun HsType
hsReturnForPurity [HsType]
hsParams
    , fnHsParamNameMaybes :: [Maybe ErrorMsg]
fnHsParamNameMaybes = [Maybe ErrorMsg]
paramNameMaybes
    }

  where contextForParam :: (String, Type) -> LH.Generator HsQualType
        contextForParam :: (ErrorMsg, Type)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
contextForParam (ErrorMsg
s, Type
t) = case Type
t of
          Internal_TPtr (Internal_TObj Class
cls) -> ErrorMsg
-> Class
-> Constness
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
receivePtr ErrorMsg
s Class
cls Constness
Nonconst
          Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> ErrorMsg
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
receiveValue ErrorMsg
s Type
t Class
cls
          Internal_TRef (Internal_TObj Class
cls) -> ErrorMsg
-> Class
-> Constness
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
receivePtr ErrorMsg
s Class
cls Constness
Nonconst
          Internal_TRef (Internal_TConst (Internal_TObj Class
cls)) -> ErrorMsg
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
receiveValue ErrorMsg
s Type
t Class
cls
          Internal_TObj Class
cls -> ErrorMsg
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
receiveValue ErrorMsg
s Type
t Class
cls
          Internal_TManual ConversionSpec
spec ->
            -- We add a typeclass constraint iff we're generating an exposed
            -- Haskell function (HsHsSide) and there is a constraint declared.
            -- If we're generating the underlying C FFI function, or if there is
            -- no constraint declared, then don't add one.
            case (HsTypeSide
side, ConversionSpec -> Maybe ConversionSpecHaskell
conversionSpecHaskell ConversionSpec
spec Maybe ConversionSpecHaskell
-> (ConversionSpecHaskell
    -> Maybe
         (HsName
          -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType))
-> Maybe
     (HsName
      -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConversionSpecHaskell
-> Maybe
     (HsName
      -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType)
conversionSpecHaskellHsArgType) of
              (HsTypeSide
LH.HsHsSide, Just HsName -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
f) -> HsName -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
f (HsName
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType)
-> HsName
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
s
              (HsTypeSide,
 Maybe
   (HsName
    -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType))
_ -> HsTypeSide
-> Type
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
handoff HsTypeSide
side Type
t
          Internal_TConst Type
t' -> (ErrorMsg, Type)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
contextForParam (ErrorMsg
s, Type
t')
          Type
_ -> HsTypeSide
-> Type
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
handoff HsTypeSide
side Type
t

        -- Use whatever type 'cppTypeToHsTypeAndUse' suggests, with no typeclass
        -- constraints.
        handoff :: LH.HsTypeSide -> Type -> LH.Generator HsQualType
        handoff :: HsTypeSide
-> Type
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
handoff HsTypeSide
side' Type
t = HsContext -> HsType -> HsQualType
HsQualType [] (HsType -> HsQualType)
-> Generator HsType
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsTypeSide -> Type -> Generator HsType
LH.cppTypeToHsTypeAndUse HsTypeSide
side' Type
t

        -- Receives a @FooPtr this => this@.
        receivePtr :: String -> Class.Class -> Constness -> LH.Generator HsQualType
        receivePtr :: ErrorMsg
-> Class
-> Constness
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
receivePtr ErrorMsg
s Class
cls Constness
cst = case HsTypeSide
side of
          HsTypeSide
LH.HsHsSide -> do
            ErrorMsg
ptrClassName <- Constness
-> Class -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsPtrClassName Constness
cst Class
cls
            let t' :: HsType
t' = HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
s
            HsQualType
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualType
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType)
-> HsQualType
-> ReaderT Env (WriterT Output (Except ErrorMsg)) 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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
ptrClassName, [HsType
t'])] HsType
t'
          HsTypeSide
LH.HsCSide -> do
            HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForForeign
            ErrorMsg
typeName <- Constness
-> Class -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsDataTypeName Constness
cst Class
cls
            HsQualType
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualType
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType)
-> HsQualType
-> ReaderT Env (WriterT Output (Except ErrorMsg)) 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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"HoppyF.Ptr")
                      (HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
typeName)

        -- Receives a @FooValue a => a@.
        receiveValue :: String -> Type -> Class.Class -> LH.Generator HsQualType
        receiveValue :: ErrorMsg
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
receiveValue ErrorMsg
s Type
t Class
cls = case HsTypeSide
side of
          HsTypeSide
LH.HsCSide -> HsTypeSide
-> Type
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
handoff HsTypeSide
side Type
t
          HsTypeSide
LH.HsHsSide -> do
            HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
            ErrorMsg
valueClassName <- Class -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
Class.toHsValueClassName Class
cls
            let t' :: HsType
t' = HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
s
            HsQualType
-> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualType
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) HsQualType)
-> HsQualType
-> ReaderT Env (WriterT Output (Except ErrorMsg)) 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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
valueClassName, [HsType
t'])] HsType
t'

-- | Renders a 'FnHsType' as a Haskell type, ignoring parameter names.  This
-- implementation uses haskell-src.
renderFnHsType :: FnHsType -> String
renderFnHsType :: FnHsType -> ErrorMsg
renderFnHsType = HsQualType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint (HsQualType -> ErrorMsg)
-> (FnHsType -> HsQualType) -> FnHsType -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FnHsType -> HsQualType
fnHsQualType

-- | Renders a 'FnHsType' as a Haskell type, including Haddock for parameter
-- names.
--
-- Unfortunately, we have to implement this ourselves, because haskell-src
-- doesn't support comments, and haskell-src-exts's comments implementation
-- relies on using specific source spans, and we don't want all that complexity
-- here.  So instead we render it ourselves, inserting "{- ^ ... -}" tags where
-- appropriate.
renderFnHsTypeWithNames :: FnHsType -> String
renderFnHsTypeWithNames :: FnHsType -> ErrorMsg
renderFnHsTypeWithNames FnHsType
fnHsType =
  [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ErrorMsg] -> ErrorMsg) -> [ErrorMsg] -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ [ErrorMsg]
renderedContextStrs [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
renderedParamStrs

  where HsQualType HsContext
assts HsType
unqualType = FnHsType -> HsQualType
fnHsQualType FnHsType
fnHsType
        paramNameMaybes :: [Maybe ErrorMsg]
paramNameMaybes = FnHsType -> [Maybe ErrorMsg]
fnHsParamNameMaybes FnHsType
fnHsType

        renderedContextStrs :: [String]
        renderedContextStrs :: [ErrorMsg]
renderedContextStrs =
          if HsContext -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsContext
assts
          then []
          else ErrorMsg
"(" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
intersperse ErrorMsg
", " (((HsQName, [HsType]) -> ErrorMsg) -> HsContext -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (HsQName, [HsType]) -> ErrorMsg
renderAsst HsContext
assts) [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg
") => "]

        renderAsst :: (HsQName, [HsType]) -> String
        renderAsst :: (HsQName, [HsType]) -> ErrorMsg
renderAsst (HsQName, [HsType])
asst = case (HsQName, [HsType])
asst of
          (UnQual (HsIdent ErrorMsg
typeclass), [HsTyVar (HsIdent ErrorMsg
typeVar)]) ->
            [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
typeclass, ErrorMsg
" ", ErrorMsg
typeVar]
          (HsQName, [HsType])
_ -> ShowS
forall a. HasCallStack => ErrorMsg -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"renderAsst: Unexpected argument: " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ (HsQName, [HsType]) -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (HsQName, [HsType])
asst

        renderedParamStrs :: [String]
        renderedParamStrs :: [ErrorMsg]
renderedParamStrs = HsType -> [Maybe ErrorMsg] -> [ErrorMsg]
renderParams HsType
unqualType [Maybe ErrorMsg]
paramNameMaybes

        renderParams :: HsType -> [Maybe String] -> [String]
        renderParams :: HsType -> [Maybe ErrorMsg] -> [ErrorMsg]
renderParams HsType
fnType' [Maybe ErrorMsg]
paramNameMaybes' = case (HsType
fnType', [Maybe ErrorMsg]
paramNameMaybes') of
          -- If there's a parameter name, then generate a Haddock comment
          -- showing the name.
          (HsTyFun HsType
a HsType
b, (Just ErrorMsg
name):[Maybe ErrorMsg]
restNames) ->
            ErrorMsg
"(" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
a ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
") {- ^ " ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
name ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
" -} -> " ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: HsType -> [Maybe ErrorMsg] -> [ErrorMsg]
renderParams HsType
b [Maybe ErrorMsg]
restNames

          -- If there's no parameter name, then don't generate any documentation
          -- for it, but continue to recur in case there are other parameters
          -- with names.
          (HsTyFun HsType
a HsType
b, Maybe ErrorMsg
Nothing:[Maybe ErrorMsg]
restNames) ->
            ErrorMsg
"(" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
a ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
") -> " ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: HsType -> [Maybe ErrorMsg] -> [ErrorMsg]
renderParams HsType
b [Maybe ErrorMsg]
restNames

          -- If we've reached the end of the TyFun chain, then we don't need to
          -- recur further.  We can use 'prettyPrint' to render the rest.
          (HsType, [Maybe ErrorMsg])
_ -> ErrorMsg
"(" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
fnType' ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: [ErrorMsg
")"]