-- This file is part of Hoppy.
--
-- Copyright 2015-2021 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 -> String
show Function
fn =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"<Function ", ExtName -> String
forall a. Show a => a -> String
show (Function -> ExtName
fnExtName Function
fn), String
" ", FnName Identifier -> String
forall a. Show a => a -> String
show (Function -> FnName Identifier
fnCName Function
fn),
            [Parameter] -> String
forall a. Show a => a -> String
show (Function -> [Parameter]
fnParams Function
fn), String
" ", Type -> String
forall a. Show a => a -> String
show (Function -> Type
fnReturn Function
fn), String
">"]

instance Exportable Function where
  sayExportCpp :: SayExportMode -> Function -> Generator ()
sayExportCpp = SayExportMode -> Function -> Generator ()
sayCppExport
  sayExportHaskell :: SayExportMode -> Function -> Generator ()
sayExportHaskell = SayExportMode -> Function -> Generator ()
sayHsExport

instance HasExtNames Function where
  getPrimaryExtName :: Function -> ExtName
getPrimaryExtName = Function -> ExtName
fnExtName

instance HasReqs Function where
  getReqs :: Function -> Reqs
getReqs = Function -> Reqs
fnReqs
  setReqs :: Reqs -> Function -> Function
setReqs Reqs
reqs Function
fn = Function
fn { fnReqs :: Reqs
fnReqs = Reqs
reqs }

instance HasAddendum Function where
  getAddendum :: Function -> Addendum
getAddendum = Function -> Addendum
fnAddendum
  setAddendum :: Addendum -> Function -> Function
setAddendum Addendum
addendum Function
fn = Function
fn { fnAddendum :: Addendum
fnAddendum = Addendum
addendum }

instance HandlesExceptions Function where
  getExceptionHandlers :: Function -> ExceptionHandlers
getExceptionHandlers = Function -> ExceptionHandlers
fnExceptionHandlers
  modifyExceptionHandlers :: (ExceptionHandlers -> ExceptionHandlers) -> Function -> Function
modifyExceptionHandlers ExceptionHandlers -> ExceptionHandlers
f Function
fn = Function
fn { fnExceptionHandlers :: ExceptionHandlers
fnExceptionHandlers = ExceptionHandlers -> ExceptionHandlers
f (ExceptionHandlers -> ExceptionHandlers)
-> ExceptionHandlers -> ExceptionHandlers
forall a b. (a -> b) -> a -> b
$ Function -> ExceptionHandlers
fnExceptionHandlers Function
fn }

-- | 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 :: 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 (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 -> String
(Int -> CallDirection -> ShowS)
-> (CallDirection -> String)
-> ([CallDirection] -> ShowS)
-> Show CallDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallDirection] -> ShowS
$cshowList :: [CallDirection] -> ShowS
show :: CallDirection -> String
$cshow :: CallDirection -> String
showsPrec :: Int -> CallDirection -> ShowS
$cshowsPrec :: Int -> CallDirection -> ShowS
Show)

-- | 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 String)) ExceptionHandlers
-> ReaderT Env (WriterT [Chunk] (Either String)) [ExceptionHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptionHandlers
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionHandlers
LC.getEffectiveExceptionHandlers ExceptionHandlers
exceptionHandlers
  let paramTypes :: [Type]
paramTypes = (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType [Parameter]
params
      catches :: Bool
catches = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ExceptionHandler] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExceptionHandler]
handlerList
      addExceptionParamNames :: [String] -> [String]
addExceptionParamNames =
        if Bool
catches then ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
LC.exceptionIdArgName, String
LC.exceptionPtrArgName]) else [String] -> [String]
forall a. a -> a
id
      addExceptionParamTypes :: [Type] -> [Type]
addExceptionParamTypes = if Bool
catches then ([Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type -> Type
ptrT Type
intT, Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT Type
voidT]) else [Type] -> [Type]
forall a. a -> a
id

      paramCount :: Int
paramCount = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
paramTypes
  [Maybe Type]
paramCTypeMaybes <- (Type
 -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type))
-> [Type]
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
LC.typeToCType [Type]
paramTypes
  let paramCTypes :: [Type]
paramCTypes = (Type -> Maybe Type -> Type) -> [Type] -> [Maybe Type] -> [Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe [Type]
paramTypes [Maybe Type]
paramCTypeMaybes
  Maybe Type
retCTypeMaybe <- Type -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
LC.typeToCType Type
retType
  let retCType :: Type
retCType = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
retType Maybe Type
retCTypeMaybe

  Reqs -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Reqs -> m ()
LC.addReqsM (Reqs -> Generator ())
-> ([Reqs] -> Reqs) -> [Reqs] -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reqs] -> Reqs
forall a. Monoid a => [a] -> a
mconcat ([Reqs] -> Generator ())
-> ReaderT Env (WriterT [Chunk] (Either String)) [Reqs]
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Type -> ReaderT Env (WriterT [Chunk] (Either String)) Reqs)
-> [Type] -> ReaderT Env (WriterT [Chunk] (Either String)) [Reqs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> ReaderT Env (WriterT [Chunk] (Either String)) Reqs
LC.typeReqs (Type
retTypeType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
paramTypes)

  String -> [String] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (ExtName -> String
LC.externalNameToCpp ExtName
extName)
                 (([String] -> [String])
-> (Type -> [String] -> [String])
-> Maybe Type
-> [String]
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String] -> [String]
forall a. a -> a
id (([String] -> [String]) -> Type -> [String] -> [String]
forall a b. a -> b -> a
const (String
"self"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)) Maybe Type
maybeThisType ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                  [String] -> [String]
addExceptionParamNames ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                  (Type -> Maybe Type -> Int -> String)
-> [Type] -> [Maybe Type] -> [Int] -> [String]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\Type
pt Maybe Type
ctm ->
                              -- 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 s ->
                                      Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
 -> Bool)
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
-> Bool
forall a b. (a -> b) -> a -> b
$ ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
conversionSpecCppConversionToCppExpr (ConversionSpecCpp
 -> Maybe (Generator () -> Maybe (Generator ()) -> Generator ()))
-> ConversionSpecCpp
-> Maybe (Generator () -> Maybe (Generator ()) -> Generator ())
forall a b. (a -> b) -> a -> b
$
                                      ConversionSpec -> ConversionSpecCpp
conversionSpecCpp ConversionSpec
s
                                    Type
_ -> Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
ctm
                              in if Bool
hasConversion then Int -> String
LC.toArgNameAlt else Int -> String
LC.toArgName)
                           [Type]
paramTypes
                           [Maybe Type]
paramCTypeMaybes
                           [Int
1..Int
paramCount])
                 ([Type] -> Type -> Type
fnT ([Type] -> [Type]
addExceptionParamTypes ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ ([Type] -> [Type])
-> (Type -> [Type] -> [Type]) -> Maybe Type -> [Type] -> [Type]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Type] -> [Type]
forall a. a -> a
id (:) Maybe Type
maybeThisType [Type]
paramCTypes)
                      Type
retCType) (Maybe (Generator ()) -> Generator ())
-> Maybe (Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$
    if Bool -> Bool
not Bool
sayBody
    then Maybe (Generator ())
forall a. Maybe a
Nothing
    else Generator () -> Maybe (Generator ())
forall a. a -> Maybe a
Just (Generator () -> Maybe (Generator ()))
-> Generator () -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ do
      Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
catches (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"try {\n"
        [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"*", String
LC.exceptionIdArgName, String
" = 0;\n"]

      -- 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
              String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"("
              let effectiveParamCount :: Int
effectiveParamCount = Int
paramCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType then Int
1 else Int
0
                  paramNames :: [String]
paramNames@(String
p1:String
p2:[String]
_) = (if Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType then (String
"(*self)"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) else [String] -> [String]
forall a. a -> a
id) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                                         (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
LC.toArgName [Int
1..]
                  assertParamCount :: Int -> Generator ()
assertParamCount Int
n =
                    Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
effectiveParamCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall a. String -> Generator a
LC.abort (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [String
"sayCppExportFn: Operator ", Operator -> String
forall a. Show a => a -> String
show Operator
op, String
" for export ", ExtName -> String
forall a. Show a => a -> String
show ExtName
extName,
                     String
" requires ", Int -> String
forall a. Show a => a -> String
show Int
n, String
" parameter(s), but has ", Int -> String
forall a. Show a => a -> String
show Int
effectiveParamCount,
                     String
"."]
              case HasCallStack => Operator -> OperatorType
Operator -> OperatorType
operatorType Operator
op of
                UnaryPrefixOperator String
symbol -> Int -> Generator ()
assertParamCount Int
1 Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
symbol, String
p1]
                UnaryPostfixOperator String
symbol -> Int -> Generator ()
assertParamCount Int
1 Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
p1, String
symbol]
                BinaryOperator String
symbol -> Int -> Generator ()
assertParamCount Int
2 Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
p1, String
symbol, String
p2]
                OperatorType
CallOperator ->
                  [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$ String
p1 String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Int
effectiveParamCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
paramNames) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
")"]
                OperatorType
ArrayOperator -> Int -> Generator ()
assertParamCount Int
2 Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
p1, String
"[", String
p2, String
"]"]
              String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
")"
            CallFn Generator ()
sayCppName -> do
              Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"self->"
              Generator ()
sayCppName
              String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"("
              Int -> Generator ()
sayCppArgNames Int
paramCount
              String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
")"
            VarRead Generator ()
sayVarName -> do
              Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"self->"
              Generator ()
sayVarName
            VarWrite Generator ()
sayVarName -> do
              Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust Maybe Type
maybeThisType) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"self->"
              Generator ()
sayVarName
              [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
" = ", Int -> String
LC.toArgName Int
1]

          -- 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
";\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 -> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return " Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator () -> Maybe (Generator ()) -> Generator ()
convFn Generator ()
sayCall Maybe (Generator ())
forall a. Maybe a
Nothing Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
";\n"
                -- 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' ->
              String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return &(" Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
");\n"
            (Internal_TObj Class
cls,
             Just (Internal_TPtr (Internal_TConst (Internal_TObj Class
cls')))) | Class
cls Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
cls' ->
              Class -> Generator () -> Generator ()
forall (m :: * -> *) a.
MonadWriter [Chunk] m =>
Class -> m a -> m ()
sayReturnNew Class
cls Generator ()
sayCall
            (Internal_TObjToHeap Class
cls, Just (Internal_TPtr (Internal_TObj Class
cls'))) | Class
cls Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
cls' ->
              Class -> Generator () -> Generator ()
forall (m :: * -> *) a.
MonadWriter [Chunk] m =>
Class -> m a -> m ()
sayReturnNew Class
cls Generator ()
sayCall
            (Internal_TToGc (Internal_TObj Class
cls),
             Just (Internal_TPtr (Internal_TObj Class
cls'))) | Class
cls Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
cls' ->
              Class -> Generator () -> Generator ()
forall (m :: * -> *) a.
MonadWriter [Chunk] m =>
Class -> m a -> m ()
sayReturnNew Class
cls Generator ()
sayCall
            (Internal_TToGc Type
retType'', Maybe Type
_) -> Type -> Maybe Type -> Generator ()
sayCallAndReturn Type
retType'' Maybe Type
retCTypeMaybe'

            (Type, Maybe Type)
ts -> String -> Generator ()
forall a. String -> Generator a
LC.abort (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"sayCppExportFn: Unexpected return types ", (Type, Maybe Type) -> String
forall a. Show a => a -> String
show (Type, Maybe Type)
ts,
                                     String
" while generating binding for ", ExtName -> String
forall a. Show a => a -> String
show ExtName
extName, String
"."]

          sayCallAndReturnDirect :: Generator ()
sayCallAndReturnDirect = String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return " Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
";\n"

      Type -> Maybe Type -> Generator ()
sayCallAndReturn Type
retType Maybe Type
retCTypeMaybe

      Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
catches (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        Interface
iface <- ReaderT Env (WriterT [Chunk] (Either String)) Interface
forall (m :: * -> *). MonadReader Env m => m Interface
LC.askInterface

        [ExceptionHandler]
-> (ExceptionHandler -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ExceptionHandler]
handlerList ((ExceptionHandler -> Generator ()) -> Generator ())
-> (ExceptionHandler -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \ExceptionHandler
handler -> do
          String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"} catch ("
          case ExceptionHandler
handler of
            CatchClass Class
cls -> String -> Maybe [String] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
String -> Maybe [String] -> Type -> m ()
LC.sayVar String
LC.exceptionVarName Maybe [String]
forall a. Maybe a
Nothing (Type -> Generator ()) -> Type -> Generator ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
refT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
constT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls
            ExceptionHandler
CatchAll -> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"..."
          String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
") {\n"

          ExceptionId
exceptionId <- case ExceptionHandler
handler of
            CatchClass Class
cls -> case Interface -> Class -> Maybe ExceptionId
interfaceExceptionClassId Interface
iface Class
cls of
              Just ExceptionId
exceptionId -> ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId
forall (m :: * -> *) a. Monad m => a -> m a
return ExceptionId
exceptionId
              Maybe ExceptionId
Nothing -> String -> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId
forall a. String -> Generator a
LC.abort (String
 -> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId)
-> String
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                         [String
"sayCppExportFn: Trying to catch non-exception class ", Class -> String
forall a. Show a => a -> String
show Class
cls,
                          String
" while generating binding for ", ExtName -> String
forall a. Show a => a -> String
show ExtName
extName, String
"."]
            ExceptionHandler
CatchAll -> ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either String)) ExceptionId
forall (m :: * -> *) a. Monad m => a -> m a
return ExceptionId
exceptionCatchAllId
          [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"*", String
LC.exceptionIdArgName, String
" = ", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
exceptionId, String
";\n"]

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

          -- 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
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return 0;\n"

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

  where sayReturnNew :: Class -> m a -> m ()
sayReturnNew Class
cls m a
sayCall =
          String -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return new" m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Identifier -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier (Class -> Identifier
Class.classIdentifier Class
cls) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"(" m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          m a
sayCall m a -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> m ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
");\n"

-- | 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 :: String
-> Type
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
check String
label Type
t' = ((String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t') String -> Maybe Type -> Maybe String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Maybe Type -> Maybe String)
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe Type)
LC.typeToCType Type
t'
    [String]
mismatches <-
      ([Maybe String] -> [String])
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
-> ReaderT Env (WriterT [Chunk] (Either String)) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
 -> ReaderT Env (WriterT [Chunk] (Either String)) [String])
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
-> ReaderT Env (WriterT [Chunk] (Either String)) [String]
forall a b. (a -> b) -> a -> b
$
      (:) (Maybe String -> [Maybe String] -> [Maybe String])
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
-> ReaderT
     Env
     (WriterT [Chunk] (Either String))
     ([Maybe String] -> [Maybe String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Type
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
check String
"return type" Type
retType
          ReaderT
  Env
  (WriterT [Chunk] (Either String))
  ([Maybe String] -> [Maybe String])
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type
 -> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String))
-> [Type]
-> ReaderT Env (WriterT [Chunk] (Either String)) [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Type
paramType -> String
-> Type
-> ReaderT Env (WriterT [Chunk] (Either String)) (Maybe String)
check String
"parameter" Type
paramType) [Type]
paramTypes
    Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
mismatches) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      String -> Generator ()
forall a. String -> Generator a
LC.abort (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      String
"sayCppArgRead: Some types within a function pointer type use non-C types, " String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
      String
"but only C types may be used.  The unsupported types are: " String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"; " [String]
mismatches [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
".  The whole function type is ", Type -> String
forall a. Show a => a -> String
show Type
t, String
"."]

    Generator ()
convertDefault

  Internal_TRef Type
t -> Type -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Type -> m ()
convertObj Type
t

  Internal_TObj Class
_ -> Type -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Type -> m ()
convertObj (Type -> Generator ()) -> Type -> Generator ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
constT Type
cppType

  Internal_TObjToHeap Class
cls -> case CallDirection
dir of
    CallDirection
ToCpp -> String -> Generator ()
forall a. HasCallStack => String -> a
error (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Class -> String
objToHeapTWrongDirectionErrorMsg (String -> Maybe String
forall a. a -> Maybe a
Just String
"sayCppArgRead") Class
cls
    CallDirection
FromCpp -> do
      Identifier -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier (Identifier -> Generator ()) -> Identifier -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Identifier
Class.classIdentifier Class
cls
      [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"* ", Int -> String
LC.toArgName Int
n, String
" = new "]
      Identifier -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier (Identifier -> Generator ()) -> Identifier -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Identifier
Class.classIdentifier Class
cls
      [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"(", Int -> String
LC.toArgNameAlt Int
n, String
");\n"]

  Internal_TToGc Type
t' -> case CallDirection
dir of
    CallDirection
ToCpp -> String -> Generator ()
forall a. HasCallStack => String -> a
error (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
toGcTWrongDirectionErrorMsg (String -> Maybe String
forall a. a -> Maybe a
Just String
"sayCppArgRead") Type
t'
    CallDirection
FromCpp -> do
      let newCppType :: Type
newCppType = case Type
t' of
            -- 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 String)) (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 (String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Int -> String
LC.toArgNameAlt Int
n) (Generator () -> Maybe (Generator ())
forall a. a -> Maybe a
Just (Generator () -> Maybe (Generator ()))
-> Generator () -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Int -> String
LC.toArgName Int
n)

  Type
_ -> Generator ()
convertDefault

  where -- 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 String)) Any)
-> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Type
maybeCType ((Type -> ReaderT Env (WriterT [Chunk] (Either String)) Any)
 -> Generator ())
-> (Type -> ReaderT Env (WriterT [Chunk] (Either String)) Any)
-> Generator ()
forall a b. (a -> b) -> a -> b
$ \Type
cType ->
          String -> ReaderT Env (WriterT [Chunk] (Either String)) Any
forall a. String -> Generator a
LC.abort (String -> ReaderT Env (WriterT [Chunk] (Either String)) Any)
-> String -> ReaderT Env (WriterT [Chunk] (Either String)) Any
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [String
"sayCppArgRead: Don't know how to convert ", CallDirection -> String
forall a. Show a => a -> String
show CallDirection
dir, String
" between C-type ", Type -> String
forall a. Show a => a -> String
show Type
cType,
           String
" and C++-type ", Type -> String
forall a. Show a => a -> String
show Type
cppType, String
"."]

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

-- | 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 =
  [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
LC.toArgName [Int
1..Int
count]

sayHsExport :: LH.SayExportMode -> Function -> LH.Generator ()
sayHsExport :: SayExportMode -> Function -> Generator ()
sayHsExport SayExportMode
mode Function
fn =
  (SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
sayHsExportFn SayExportMode
mode (ExtName
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Function -> ExtName)
-> Function
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Function -> ExtName
fnExtName (Function
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Function -> ExtName)
-> Function
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> ExtName
fnExtName (Function
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Function -> Purity)
-> Function
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> Purity
fnPurity (Function
 -> [Parameter] -> Type -> ExceptionHandlers -> Generator ())
-> (Function -> [Parameter])
-> Function
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
   Function -> [Parameter]
fnParams (Function -> Type -> ExceptionHandlers -> Generator ())
-> (Function -> Type)
-> Function
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> Type
fnReturn (Function -> ExceptionHandlers -> Generator ())
-> (Function -> ExceptionHandlers) -> Function -> Generator ()
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Function -> ExceptionHandlers
fnExceptionHandlers) Function
fn

-- | 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 (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 :: String
hsFnName = ExtName -> String
LH.toHsFnName' ExtName
foreignName
      hsFnImportedName :: String
hsFnImportedName = String
hsFnName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"

  case SayExportMode
mode of
    SayExportMode
LH.SayExportForeignImports ->
      String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"generating imports for function " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> String
forall a. Show a => a -> String
show ExtName
extName) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        -- 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
        [String] -> Generator ()
LH.saysLn [String
"foreign import ccall \"", ExtName -> String
LC.externalNameToCpp ExtName
extName, String
"\" ", String
hsFnImportedName,
                    String
" :: ", FnHsType -> String
renderFnHsType FnHsType
hsCType]

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

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

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

        String
exceptionHandling <-
          if Bool
catches
          then do Interface
iface <- Generator Interface
LH.askInterface
                  Module
currentModule <- Generator Module
LH.askModule
                  let exceptionSupportModule :: Maybe Module
exceptionSupportModule = Interface -> Maybe Module
interfaceExceptionSupportModule Interface
iface
                  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Module
exceptionSupportModule Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> Maybe Module
forall a. a -> Maybe a
Just Module
currentModule) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
                    HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ())
-> (Module -> HsImportSet) -> Module -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsImportSet
hsWholeModuleImport (String -> HsImportSet)
-> (Module -> String) -> Module -> HsImportSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Module -> String
LH.getModuleName Interface
iface (Module -> Generator ()) -> Generator Module -> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                    Generator Module -> Maybe Module -> Generator Module
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (String -> Generator Module
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                                String
"Internal error, an exception support module is not available")
                    Maybe Module
exceptionSupportModule
                  HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)", HsImportSet
hsImportForRuntime]
                  String -> ReaderT Env (WriterT Output (Except String)) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"HoppyFHR.internalHandleExceptions exceptionDb' $"
          else String -> ReaderT Env (WriterT Output (Except String)) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""

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

    SayExportMode
LH.SayExportBoot ->
      -- 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 (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 -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
dir Type
t String
fromVar String
toVar =
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"processing argument of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
  case Type
t of
    Type
Internal_TVoid -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ String
"TVoid is not a valid argument type"
    -- 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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)",
                                 HsImportSet
hsImportForRuntime]
        String
castMethodName <- Constness
-> Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsCastMethodName Constness
Nonconst Class
cls
        [String] -> Generator ()
LH.saysLn [String
"HoppyFHR.withCppPtr (", String
castMethodName, String
" ", String
fromVar,
                   String
") $ \\", String
toVar, String
" ->"]
      CallDirection
FromCpp -> do
        String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
        [String] -> Generator ()
LH.saysLn [String
"let ", String
toVar, String
" = ", String
ctorName, String
" ", String
fromVar, String
" in"]
    Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> case CallDirection
dir of
      CallDirection
ToCpp -> do
        -- 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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)",
                                 HsImportSet
hsImportForPrelude,
                                 HsImportSet
hsImportForRuntime]
        String
withValuePtrName <- Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsWithValuePtrName Class
cls
        [String] -> Generator ()
LH.saysLn [String
withValuePtrName, String
" ", String
fromVar,
                   String
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", String
toVar, String
" ->"]
      CallDirection
FromCpp -> do
        String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
        [String] -> Generator ()
LH.saysLn [String
"let ", String
toVar, String
" = ", String
ctorName, String
" ", String
fromVar, String
" in"]
    Internal_TPtr Type
_ -> Generator ()
noConversion
    Internal_TRef Type
t' -> CallDirection -> Type -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
dir (Type -> Type
ptrT Type
t') String
fromVar String
toVar
    Internal_TFn {} -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"TFn unimplemented"
    Internal_TObj Class
cls -> case CallDirection
dir of
      CallDirection
ToCpp -> do
        -- 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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)",
                                 HsImportSet
hsImportForPrelude,
                                 HsImportSet
hsImportForRuntime]
        String
withValuePtrName <- Class -> ReaderT Env (WriterT Output (Except String)) String
Class.toHsWithValuePtrName Class
cls
        [String] -> Generator ()
LH.saysLn [String
withValuePtrName, String
" ", String
fromVar,
                String
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", String
toVar, String
" ->"]
      CallDirection
FromCpp -> case ClassHaskellConversion -> Maybe (Generator ())
Class.classHaskellConversionFromCppFn (ClassHaskellConversion -> Maybe (Generator ()))
-> ClassHaskellConversion -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ Class -> ClassHaskellConversion
LH.getClassHaskellConversion Class
cls of
        Just Generator ()
_ -> do
          HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(>>=)",
                                   HsImportSet
hsImportForRuntime]
          String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
          [String] -> Generator ()
LH.saysLn [String
"HoppyFHR.decode (", String
ctorName, String
" ", String
fromVar, String
") >>= \\", String
toVar, String
" ->"]
        Maybe (Generator ())
Nothing ->
          String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [String
"Can't pass a TObj of ", Class -> String
forall a. Show a => a -> String
show Class
cls,
           String
" from C++ to Haskell because no class decode conversion is defined"]
    Internal_TObjToHeap Class
cls -> case CallDirection
dir of
      CallDirection
ToCpp -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Class -> String
objToHeapTWrongDirectionErrorMsg Maybe String
forall a. Maybe a
Nothing Class
cls
      CallDirection
FromCpp -> CallDirection -> Type -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
dir (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) String
fromVar String
toVar
    Internal_TToGc Type
t' -> case CallDirection
dir of
      CallDirection
ToCpp -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
toGcTWrongDirectionErrorMsg Maybe String
forall a. Maybe a
Nothing Type
t'
      CallDirection
FromCpp -> do
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(>>=)",
                                 HsImportSet
hsImportForRuntime]
        String
ctorName <-
          ReaderT Env (WriterT Output (Except String)) String
-> (Class -> ReaderT Env (WriterT Output (Except String)) String)
-> Maybe Class
-> ReaderT Env (WriterT Output (Except String)) String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ReaderT Env (WriterT Output (Except String)) String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (WriterT Output (Except String)) String)
-> String -> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
tToGcInvalidFormErrorMessage Maybe String
forall a. Maybe a
Nothing Type
t')
                (Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst) (Maybe Class
 -> ReaderT Env (WriterT Output (Except String)) String)
-> Maybe Class
-> ReaderT Env (WriterT Output (Except String)) String
forall a b. (a -> b) -> a -> b
$
          case Type -> Type
stripConst Type
t' of
            Internal_TObj Class
cls -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
            Internal_TRef (Internal_TConst (Internal_TObj Class
cls)) -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
            Internal_TRef (Internal_TObj Class
cls) -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
            Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
            Internal_TPtr (Internal_TObj Class
cls) -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
            Type
_ -> Maybe Class
forall a. Maybe a
Nothing
        [String] -> Generator ()
LH.saysLn [String
"HoppyFHR.toGc (", String
ctorName, String
" ", String
fromVar, String
") >>= \\", String
toVar, String
" ->"]
    Internal_TConst Type
t' -> CallDirection -> Type -> String -> String -> Generator ()
sayHsArgProcessing CallDirection
dir Type
t' String
fromVar String
toVar

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

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

-- | 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 -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t [String]
callWords =
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"processing return value of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
  case Type
t of
    Type
Internal_TVoid -> Generator ()
sayCall
    -- 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
          String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
          [String] -> Generator ()
LH.saysLn [String
"HoppyP.fmap ", String
ctorName]
          Generator ()
sayCall
        CallDirection
FromCpp -> do
          HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
hsImportForPrelude, HsImportSet
hsImportForRuntime]
          String -> Generator ()
LH.sayLn String
"HoppyP.fmap HoppyFHR.toPtr"
          Generator ()
sayCall
    -- 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
        String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
        [String] -> Generator ()
LH.saysLn [String
"HoppyP.fmap ", String
ctorName]
        Generator ()
sayCall
      CallDirection
FromCpp -> do
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
hsImportForPrelude, HsImportSet
hsImportForRuntime]
        String -> Generator ()
LH.sayLn String
"HoppyP.fmap HoppyFHR.toPtr"
        Generator ()
sayCall
    Internal_TPtr Type
_ -> Generator ()
sayCall
    Internal_TRef Type
t' -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT Type
t') [String]
callWords
    Internal_TFn {} -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"TFn unimplemented"
    Internal_TObj Class
cls -> case CallDirection
dir of
      CallDirection
ToCpp -> case ClassHaskellConversion -> Maybe (Generator ())
Class.classHaskellConversionFromCppFn (ClassHaskellConversion -> Maybe (Generator ()))
-> ClassHaskellConversion -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ Class -> ClassHaskellConversion
LH.getClassHaskellConversion Class
cls of
        Just Generator ()
_ -> do
          HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> [String] -> HsImportSet
hsImports String
"Prelude" [String
"(.)", String
"(=<<)"],
                                   HsImportSet
hsImportForRuntime]
          String
ctorName <- Managed
-> Constness
-> Class
-> ReaderT Env (WriterT Output (Except String)) String
Class.toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
          [String] -> Generator ()
LH.saysLn [String
"(HoppyFHR.decodeAndDelete . ", String
ctorName, String
") =<<"]
          Generator ()
sayCall
        Maybe (Generator ())
Nothing ->
          String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [String
"Can't return a TObj of ", Class -> String
forall a. Show a => a -> String
show Class
cls,
           String
" from C++ to Haskell because no class decode conversion is defined"]
      CallDirection
FromCpp -> do
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> [String] -> HsImportSet
hsImports String
"Prelude" [String
"(.)", String
"(=<<)"],
                                 HsImportSet
hsImportForPrelude,
                                 HsImportSet
hsImportForRuntime]
        String -> Generator ()
LH.sayLn String
"(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<"
        Generator ()
sayCall
    Internal_TObjToHeap Class
cls -> case CallDirection
dir of
      CallDirection
ToCpp -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) [String]
callWords
      CallDirection
FromCpp -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Class -> String
objToHeapTWrongDirectionErrorMsg Maybe String
forall a. Maybe a
Nothing Class
cls
    Internal_TToGc Type
t' -> case CallDirection
dir of
      CallDirection
ToCpp -> do
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(=<<)",
                                 HsImportSet
hsImportForRuntime]
        String -> Generator ()
LH.sayLn String
"HoppyFHR.toGc =<<"
        -- 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 -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir (Type -> Type
ptrT Type
t') [String]
callWords
          Type
_ -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t' [String]
callWords
      CallDirection
FromCpp -> String -> Generator ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Type -> String
toGcTWrongDirectionErrorMsg Maybe String
forall a. Maybe a
Nothing Type
t'
    Internal_TConst Type
t' -> CallDirection -> Type -> [String] -> Generator ()
sayHsCallAndProcessReturn CallDirection
dir Type
t' [String]
callWords

    Internal_TManual ConversionSpec
s -> do
      -- 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (case CallDirection
dir of
                    CallDirection
ToCpp -> ConversionSpecHaskell -> ConversionMethod (Generator ())
conversionSpecHaskellFromCppFn
                    CallDirection
FromCpp -> ConversionSpecHaskell -> ConversionMethod (Generator ())
conversionSpecHaskellToCppFn) (Maybe ConversionSpecHaskell
 -> Maybe (ConversionMethod (Generator ())))
-> Maybe ConversionSpecHaskell
-> Maybe (ConversionMethod (Generator ()))
forall a b. (a -> b) -> a -> b
$
            ConversionSpec -> Maybe ConversionSpecHaskell
conversionSpecHaskell ConversionSpec
s
          throwForNoConversion :: ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion =
            String -> ReaderT Env (WriterT Output (Except String)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (WriterT Output (Except String)) a)
-> String -> ReaderT Env (WriterT Output (Except String)) a
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [String
"No conversion defined for ", ConversionSpec -> String
forall a. Show a => a -> String
show ConversionSpec
s,
             case CallDirection
dir of
               CallDirection
ToCpp -> String
" from C++ to Haskell"
               CallDirection
FromCpp -> String
" to C++ from Haskell"]
      case Maybe (ConversionMethod (Generator ()))
maybeGen of
        Just (CustomConversion Generator ()
gen) -> do
          HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(=<<)"
          String -> Generator ()
LH.sayLn String
"("
          Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent Generator ()
gen
          String -> Generator ()
LH.sayLn String
") =<<"
        Just ConversionMethod (Generator ())
BinaryCompatible -> () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ConversionMethod (Generator ())
ConversionUnsupported -> Generator ()
forall a. ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion
        Maybe (ConversionMethod (Generator ()))
Nothing -> Generator ()
forall a. ReaderT Env (WriterT Output (Except String)) a
throwForNoConversion
      Generator ()
sayCall

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

-- | 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 String]
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 (t :: * -> *) a. Foldable t => t a -> Bool
null ([ExceptionHandler] -> Bool) -> [ExceptionHandler] -> Bool
forall a b. (a -> b) -> a -> b
$ ExceptionHandlers -> [ExceptionHandler]
exceptionHandlersList ExceptionHandlers
exceptionHandlers
      getsExcParams :: Bool
getsExcParams = Bool
catches Bool -> Bool -> Bool
&& HsTypeSide
side HsTypeSide -> HsTypeSide -> Bool
forall a. Eq a => a -> a -> Bool
== HsTypeSide
LH.HsCSide

      paramTypes :: [Type]
paramTypes =
        (if Bool
getsExcParams then ([Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type -> Type
ptrT Type
intT, Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT Type
voidT]) else [Type] -> [Type]
forall a. a -> a
id) ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
        (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType [Parameter]
params

      paramNameMaybes :: [Maybe String]
paramNameMaybes =
        (if Bool
getsExcParams then ([Maybe String] -> [Maybe String] -> [Maybe String]
forall a. [a] -> [a] -> [a]
++ [String -> Maybe String
forall a. a -> Maybe a
Just String
"excId", String -> Maybe String
forall a. a -> Maybe a
Just String
"excPtr"]) else [Maybe String] -> [Maybe String]
forall a. a -> a
id) ([Maybe String] -> [Maybe String])
-> [Maybe String] -> [Maybe String]
forall a b. (a -> b) -> a -> b
$
        (Parameter -> Maybe String) -> [Parameter] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Maybe String
parameterName [Parameter]
params

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

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

  [HsQualType]
paramQualTypes <- ((String, Type)
 -> ReaderT Env (WriterT Output (Except String)) HsQualType)
-> [(String, Type)]
-> ReaderT Env (WriterT Output (Except String)) [HsQualType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, Type)
-> ReaderT Env (WriterT Output (Except String)) HsQualType
contextForParam ([(String, Type)]
 -> ReaderT Env (WriterT Output (Except String)) [HsQualType])
-> [(String, Type)]
-> ReaderT Env (WriterT Output (Except String)) [HsQualType]
forall a b. (a -> b) -> a -> b
$ [String] -> [Type] -> [(String, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
defaultedParamNames [Type]
paramTypes
  let context :: HsContext
context = (HsQualType -> HsContext) -> [HsQualType] -> HsContext
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(HsQualType HsContext
ctx HsType
_) -> HsContext
ctx) [HsQualType]
paramQualTypes :: HsContext
      hsParams :: [HsType]
hsParams = (HsQualType -> HsType) -> [HsQualType] -> [HsType]
forall a b. (a -> b) -> [a] -> [b]
map (\(HsQualType HsContext
_ HsType
t) -> HsType
t) [HsQualType]
paramQualTypes

  -- 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 (m :: * -> *) a. Monad m => a -> m a
return HsType
hsReturnInitial
    (Purity, HsTypeSide)
_ -> do
      HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
      HsType -> Generator HsType
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType -> Generator HsType) -> HsType -> Generator HsType
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
"HoppyP.IO") HsType
hsReturnInitial

  FnHsType -> Generator FnHsType
forall (m :: * -> *) a. Monad m => a -> m a
return FnHsType :: HsQualType -> [Maybe String] -> FnHsType
FnHsType
    { fnHsQualType :: HsQualType
fnHsQualType = HsContext -> HsType -> HsQualType
HsQualType HsContext
context (HsType -> HsQualType) -> HsType -> HsQualType
forall a b. (a -> b) -> a -> b
$ (HsType -> HsType -> HsType) -> HsType -> [HsType] -> HsType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsType -> HsType -> HsType
HsTyFun HsType
hsReturnForPurity [HsType]
hsParams
    , fnHsParamNameMaybes :: [Maybe String]
fnHsParamNameMaybes = [Maybe String]
paramNameMaybes
    }

  where contextForParam :: (String, Type) -> LH.Generator HsQualType
        contextForParam :: (String, Type)
-> ReaderT Env (WriterT Output (Except String)) HsQualType
contextForParam (String
s, Type
t) = case Type
t of
          Internal_TPtr (Internal_TObj Class
cls) -> String
-> Class
-> Constness
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receivePtr String
s Class
cls Constness
Nonconst
          Internal_TPtr (Internal_TConst (Internal_TObj Class
cls)) -> String
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receiveValue String
s Type
t Class
cls
          Internal_TRef (Internal_TObj Class
cls) -> String
-> Class
-> Constness
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receivePtr String
s Class
cls Constness
Nonconst
          Internal_TRef (Internal_TConst (Internal_TObj Class
cls)) -> String
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receiveValue String
s Type
t Class
cls
          Internal_TObj Class
cls -> String
-> Type
-> Class
-> ReaderT Env (WriterT Output (Except String)) HsQualType
receiveValue String
s Type
t Class
cls
          Internal_TManual ConversionSpec
spec ->
            -- 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 String)) HsQualType))
-> Maybe
     (HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConversionSpecHaskell
-> Maybe
     (HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType)
conversionSpecHaskellHsArgType) of
              (HsTypeSide
LH.HsHsSide, Just HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType
f) -> HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType
f (HsName -> ReaderT Env (WriterT Output (Except String)) HsQualType)
-> HsName
-> ReaderT Env (WriterT Output (Except String)) HsQualType
forall a b. (a -> b) -> a -> b
$ String -> HsName
HsIdent String
s
              (HsTypeSide,
 Maybe
   (HsName
    -> ReaderT Env (WriterT Output (Except String)) HsQualType))
_ -> HsTypeSide
-> Type -> ReaderT Env (WriterT Output (Except String)) HsQualType
handoff HsTypeSide
side Type
t
          Internal_TConst Type
t' -> (String, Type)
-> ReaderT Env (WriterT Output (Except String)) HsQualType
contextForParam (String
s, Type
t')
          Type
_ -> HsTypeSide
-> Type -> ReaderT Env (WriterT Output (Except String)) HsQualType
handoff HsTypeSide
side Type
t

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

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

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

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

-- | 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 -> String
renderFnHsTypeWithNames FnHsType
fnHsType =
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
renderedContextStrs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
renderedParamStrs

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

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

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

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

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

          -- 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 String
Nothing:[Maybe String]
restNames) ->
            String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
") -> " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsType -> [Maybe String] -> [String]
renderParams HsType
b [Maybe String]
restNames

          -- 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 String])
_ -> String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
fnType' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String
")"]