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

-- | Interface for defining bindings to C++ classes.
module Foreign.Hoppy.Generator.Spec.Class (
  -- * Data type
  Class,
  -- * Construction
  makeClass,
  -- * Properties
  -- ** Common
  classExtName,
  classIdentifier,
  classReqs,
  classAddendum,
  -- ** Class hierarchy
  classSuperclasses,
  classIsMonomorphicSuperclass, classSetMonomorphicSuperclass,
  classIsSubclassOfMonomorphic, classSetSubclassOfMonomorphic,
  -- ** Entities
  classEntities, classAddEntities, classVariables, classCtors, classMethods,
  classEntityPrefix, classSetEntityPrefix,
  classDtorIsPublic, classSetDtorPrivate,
  classConversion,
  classIsException, classMakeException,
  -- * Entity types
  ClassEntity (..), IsClassEntity (..),
  classEntityExtName, classEntityExtNames,
  classEntityForeignName, classEntityForeignName',
  -- ** Class variables
  ClassVariable,
  -- *** Construction
  makeClassVariable, makeClassVariable_,
  mkClassVariable, mkClassVariable_,
  mkStaticClassVariable,
  mkStaticClassVariable_,
  -- ** Constructors
  Ctor,
  -- *** Construction
  makeCtor, makeCtor_,
  mkCtor, mkCtor_,
  -- *** Properties
  ctorExtName,
  ctorParams,
  ctorExceptionHandlers,
  -- ** Methods (member functions)
  Method, MethodApplicability (..), Staticness (..), MethodImpl (..),
  -- *** Construction
  makeMethod, makeMethod_,
  makeFnMethod, makeFnMethod_,
  mkMethod, mkMethod_, mkMethod', mkMethod'_,
  mkConstMethod, mkConstMethod_, mkConstMethod', mkConstMethod'_,
  mkStaticMethod, mkStaticMethod_, mkStaticMethod', mkStaticMethod'_,
  -- *** Properties
  methodExtName, methodImpl, methodApplicability, methodConst, methodStatic, methodPurity,
  methodParams, methodReturn, methodExceptionHandlers,
  -- ** Class properties (getter/setter pairs)
  Prop,
  -- ** Construction
  mkProp, mkProp_,
  mkStaticProp, mkStaticProp_,
  mkBoolIsProp, mkBoolIsProp_,
  mkBoolHasProp, mkBoolHasProp_,
  -- * Conversions
  ClassConversion (..), classConversionNone, classModifyConversion, classSetConversion,
  ClassHaskellConversion (..), classSetHaskellConversion,
  -- * Haskell generator
  -- ** Names
  toHsValueClassName, toHsValueClassName',
  toHsWithValuePtrName, toHsWithValuePtrName',
  toHsPtrClassName, toHsPtrClassName',
  toHsCastMethodName, toHsCastMethodName',
  toHsDownCastClassName, toHsDownCastClassName',
  toHsDownCastMethodName, toHsDownCastMethodName',
  toHsCastPrimitiveName, toHsCastPrimitiveName',
  toHsConstCastFnName, toHsConstCastFnName',
  toHsDataTypeName, toHsDataTypeName',
  toHsDataCtorName, toHsDataCtorName',
  toHsClassDeleteFnName',
  toHsClassDeleteFnPtrName',
  toHsCtorName, toHsCtorName',
  toHsMethodName, toHsMethodName',
  toHsClassEntityName, toHsClassEntityName',
  -- * Internal
  classFindCopyCtor,
  sayCppExportVar,
  sayHsExportVar,
  ) where

import Control.Monad (forM, forM_, unless, when)
import Control.Monad.Except (throwError)
import Data.Char (toUpper)
import Data.Function (on)
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.List (intersperse)
import Foreign.Hoppy.Generator.Common (fromMaybeM, lowerFirst)
import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Cpp as LC
import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as LH
import Foreign.Hoppy.Generator.Spec.Base
import qualified Foreign.Hoppy.Generator.Spec.Function as Function
import Foreign.Hoppy.Generator.Types (boolT, constT, fnT, objT, ptrT, refT, voidT)
import GHC.Stack (HasCallStack)
import Language.Haskell.Syntax (
  HsName (HsIdent),
  HsQName (UnQual),
  HsType (HsTyCon, HsTyFun, HsTyVar),
  )

-- | A C++ class declaration.  See 'IsClassEntity' for more information about the
-- interaction between a class's names and the names of entities within the
-- class.
--
-- Use this data type's 'HasReqs' instance to make the class accessible.  You do
-- not need to add requirements for methods' parameter or return types.
data Class = Class
  { Class -> ExtName
classExtName :: ExtName
    -- ^ The class's external name.
  , Class -> Identifier
classIdentifier :: Identifier
    -- ^ The identifier used to refer to the class.
  , Class -> [Class]
classSuperclasses :: [Class]
    -- ^ The class's public superclasses.
  , Class -> [ClassEntity]
classEntities :: [ClassEntity]
    -- ^ The class's entities.
  , Class -> Bool
classDtorIsPublic :: Bool
    -- ^ The class's methods.
  , Class -> ClassConversion
classConversion :: ClassConversion
    -- ^ Behaviour for converting objects to and from foriegn values.
  , Class -> Reqs
classReqs :: Reqs
    -- ^ Requirements for bindings to access this class.
  , Class -> Addendum
classAddendum :: Addendum
    -- ^ The class's addendum.
  , Class -> Bool
classIsMonomorphicSuperclass :: Bool
    -- ^ This is true for classes passed through
    -- 'classSetMonomorphicSuperclass'.
  , Class -> Bool
classIsSubclassOfMonomorphic :: Bool
    -- ^ This is true for classes passed through
    -- 'classSetSubclassOfMonomorphic'.
  , Class -> Bool
classIsException :: Bool
    -- ^ Whether to support using the class as a C++ exception.
  , Class -> ErrorMsg
classEntityPrefix :: String
    -- ^ The prefix applied to the external names of entities (methods, etc.)
    -- within this class when determining the names of foreign languages'
    -- corresponding bindings.  This defaults to the external name of the class,
    -- plus an underscore.  Changing this allows you to potentially have
    -- entities with the same foreign name in separate modules.  This may be the
    -- empty string, in which case the foreign name will simply be the external
    -- name of the entity.
    --
    -- This does __not__ affect the things' external names themselves; external
    -- names must still be unique in an interface.  For instance, a method with
    -- external name @bar@ in a class with external name @Flab@ and prefix
    -- @Flob_@ will use the effective external name @Flab_bar@, but the
    -- generated name in say Haskell would be @Flob_bar@.
    --
    -- See 'IsClassEntity' and 'classSetEntityPrefix'.
  }

instance Eq Class where
  == :: Class -> Class -> Bool
(==) = ExtName -> ExtName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ExtName -> ExtName -> Bool)
-> (Class -> ExtName) -> Class -> Class -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Class -> ExtName
classExtName

instance Ord Class where
  compare :: Class -> Class -> Ordering
compare = ExtName -> ExtName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ExtName -> ExtName -> Ordering)
-> (Class -> ExtName) -> Class -> Class -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Class -> ExtName
classExtName

instance Show Class where
  show :: Class -> ErrorMsg
show Class
cls =
    [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"<Class ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Class -> ExtName
classExtName Class
cls), ErrorMsg
" ", Identifier -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Class -> Identifier
classIdentifier Class
cls), ErrorMsg
">"]

instance Exportable Class where
  sayExportCpp :: SayExportMode -> Class -> Generator ()
sayExportCpp = SayExportMode -> Class -> Generator ()
sayCppExport

  sayExportHaskell :: SayExportMode -> Class -> Generator ()
sayExportHaskell = SayExportMode -> Class -> Generator ()
sayHsExport

  getExportExceptionClass :: Class -> Maybe Class
getExportExceptionClass Class
cls =
    if Class -> Bool
classIsException Class
cls
    then Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
    else Maybe Class
forall a. Maybe a
Nothing

instance HasExtNames Class where
  getPrimaryExtName :: Class -> ExtName
getPrimaryExtName = Class -> ExtName
classExtName
  getNestedExtNames :: Class -> [ExtName]
getNestedExtNames Class
cls = (ClassEntity -> [ExtName]) -> [ClassEntity] -> [ExtName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Class -> ClassEntity -> [ExtName]
classEntityExtNames Class
cls) ([ClassEntity] -> [ExtName]) -> [ClassEntity] -> [ExtName]
forall a b. (a -> b) -> a -> b
$ Class -> [ClassEntity]
classEntities Class
cls

instance HasReqs Class where
  getReqs :: Class -> Reqs
getReqs = Class -> Reqs
classReqs
  setReqs :: Reqs -> Class -> Class
setReqs Reqs
reqs Class
cls = Class
cls { classReqs = reqs }

instance HasAddendum Class where
  getAddendum :: Class -> Addendum
getAddendum = Class -> Addendum
classAddendum
  setAddendum :: Addendum -> Class -> Class
setAddendum Addendum
addendum Class
cls = Class
cls { classAddendum = addendum }

-- | Creates a binding for a C++ class and its contents.
makeClass :: Identifier
          -> Maybe ExtName
          -- ^ An optional external name; will be automatically derived from the
          -- identifier if absent by dropping leading namespaces, and taking the
          -- last component (sans template arguments).
          -> [Class]  -- ^ Superclasses.
          -> [ClassEntity]
          -> Class
makeClass :: Identifier -> Maybe ExtName -> [Class] -> [ClassEntity] -> Class
makeClass Identifier
identifier Maybe ExtName
maybeExtName [Class]
supers [ClassEntity]
entities =
  let extName :: ExtName
extName = HasCallStack => Identifier -> Maybe ExtName -> ExtName
Identifier -> Maybe ExtName -> ExtName
extNameOrIdentifier Identifier
identifier Maybe ExtName
maybeExtName
  in Class
     { classIdentifier :: Identifier
classIdentifier = Identifier
identifier
     , classExtName :: ExtName
classExtName = ExtName
extName
     , classSuperclasses :: [Class]
classSuperclasses = [Class]
supers
     , classEntities :: [ClassEntity]
classEntities = [ClassEntity]
entities
     , classDtorIsPublic :: Bool
classDtorIsPublic = Bool
True
     , classConversion :: ClassConversion
classConversion = ClassConversion
classConversionNone
     , classReqs :: Reqs
classReqs = Reqs
forall a. Monoid a => a
mempty
     , classAddendum :: Addendum
classAddendum = Addendum
forall a. Monoid a => a
mempty
     , classIsMonomorphicSuperclass :: Bool
classIsMonomorphicSuperclass = Bool
False
     , classIsSubclassOfMonomorphic :: Bool
classIsSubclassOfMonomorphic = Bool
False
     , classIsException :: Bool
classIsException = Bool
False
     , classEntityPrefix :: ErrorMsg
classEntityPrefix = ExtName -> ErrorMsg
fromExtName ExtName
extName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_"
     }

-- | Sets the prefix applied to foreign languages' entities generated from
-- methods, etc. within the class.
--
-- See 'IsClassEntity' and 'classEntityPrefix'.
classSetEntityPrefix :: String -> Class -> Class
classSetEntityPrefix :: ErrorMsg -> Class -> Class
classSetEntityPrefix ErrorMsg
prefix Class
cls = Class
cls { classEntityPrefix = prefix }

-- | Adds constructors to a class.
classAddEntities :: [ClassEntity] -> Class -> Class
classAddEntities :: [ClassEntity] -> Class -> Class
classAddEntities [ClassEntity]
ents Class
cls =
  if [ClassEntity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassEntity]
ents then Class
cls else Class
cls { classEntities = classEntities cls ++ ents }

-- | Returns all of the class's variables.
classVariables :: Class -> [ClassVariable]
classVariables :: Class -> [ClassVariable]
classVariables = (ClassEntity -> Maybe ClassVariable)
-> [ClassEntity] -> [ClassVariable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ClassEntity -> Maybe ClassVariable
pickVar ([ClassEntity] -> [ClassVariable])
-> (Class -> [ClassEntity]) -> Class -> [ClassVariable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [ClassEntity]
classEntities
  where pickVar :: ClassEntity -> Maybe ClassVariable
pickVar ClassEntity
ent = case ClassEntity
ent of
          CEVar ClassVariable
v -> ClassVariable -> Maybe ClassVariable
forall a. a -> Maybe a
Just ClassVariable
v
          CECtor Ctor
_ -> Maybe ClassVariable
forall a. Maybe a
Nothing
          CEMethod Method
_ -> Maybe ClassVariable
forall a. Maybe a
Nothing
          CEProp Prop
_ -> Maybe ClassVariable
forall a. Maybe a
Nothing

-- | Returns all of the class's constructors.
classCtors :: Class -> [Ctor]
classCtors :: Class -> [Ctor]
classCtors = (ClassEntity -> Maybe Ctor) -> [ClassEntity] -> [Ctor]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ClassEntity -> Maybe Ctor
pickCtor ([ClassEntity] -> [Ctor])
-> (Class -> [ClassEntity]) -> Class -> [Ctor]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [ClassEntity]
classEntities
  where pickCtor :: ClassEntity -> Maybe Ctor
pickCtor ClassEntity
ent = case ClassEntity
ent of
          CEVar ClassVariable
_ -> Maybe Ctor
forall a. Maybe a
Nothing
          CECtor Ctor
ctor -> Ctor -> Maybe Ctor
forall a. a -> Maybe a
Just Ctor
ctor
          CEMethod Method
_ -> Maybe Ctor
forall a. Maybe a
Nothing
          CEProp Prop
_ -> Maybe Ctor
forall a. Maybe a
Nothing

-- | Returns all of the class's methods, including methods generated from
-- 'Prop's.
classMethods :: Class -> [Method]
classMethods :: Class -> [Method]
classMethods = (ClassEntity -> [Method]) -> [ClassEntity] -> [Method]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ClassEntity -> [Method]
pickMethods ([ClassEntity] -> [Method])
-> (Class -> [ClassEntity]) -> Class -> [Method]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [ClassEntity]
classEntities
  where pickMethods :: ClassEntity -> [Method]
pickMethods ClassEntity
ent = case ClassEntity
ent of
          CEVar ClassVariable
_ -> []
          CECtor Ctor
_ -> []
          CEMethod Method
m -> [Method
m]
          CEProp (Prop [Method]
ms) -> [Method]
ms

-- | Marks a class's destructor as private, so that a binding for it won't be
-- generated.
classSetDtorPrivate :: Class -> Class
classSetDtorPrivate :: Class -> Class
classSetDtorPrivate Class
cls = Class
cls { classDtorIsPublic = False }

-- | Explicitly marks a class as being monomorphic (i.e. not having any
-- virtual methods or destructors).  By default, Hoppy assumes that a class that
-- is derived is also polymorphic, but it can happen that this is not the case.
-- Downcasting with @dynamic_cast@ from such classes is not available.  See also
-- 'classSetSubclassOfMonomorphic'.
classSetMonomorphicSuperclass :: Class -> Class
classSetMonomorphicSuperclass :: Class -> Class
classSetMonomorphicSuperclass Class
cls = Class
cls { classIsMonomorphicSuperclass = True }

-- | Marks a class as being derived from some monomorphic superclass.  This
-- prevents any downcasting to this class.  Generally it is better to use
-- 'classSetMonomorphicSuperclass' on the specific superclasses that are
-- monomorphic, but in cases where this is not possible, this function can be
-- applied to the subclass instead.
classSetSubclassOfMonomorphic :: Class -> Class
classSetSubclassOfMonomorphic :: Class -> Class
classSetSubclassOfMonomorphic Class
cls = Class
cls { classIsSubclassOfMonomorphic = True }

-- | Marks a class as being used as an exception.  This makes the class
-- throwable and catchable.
classMakeException :: Class -> Class
classMakeException :: Class -> Class
classMakeException Class
cls = case Class -> Bool
classIsException Class
cls of
  Bool
False -> Class
cls { classIsException = True }
  Bool
True -> Class
cls

-- | Separately from passing object handles between C++ and foreign languages,
-- objects can also be made to implicitly convert to native values in foreign
-- languages.  A single such type may be associated with any C++ class for each
-- foreign language.  The foreign type and the conversion process in each
-- direction are specified using this object.  Converting a C++ object to a
-- foreign value is also called decoding, and vice versa is called encoding.  A
-- class may be convertible in one direction and not the other.
--
-- To use these implicit conversions, instead of specifying an object handle
-- type such as
-- @'Foreign.Hoppy.Generator.Types.ptrT' . 'Foreign.Hoppy.Generator.Types.objT'@
-- or
-- @'Foreign.Hoppy.Generator.Types.refT' . 'Foreign.Hoppy.Generator.Types.objT'@,
-- use 'Foreign.Hoppy.Generator.Types.objT' directly.
--
-- The subfields in this object specify how to do conversions between C++ and
-- foreign languages.
data ClassConversion = ClassConversion
  { ClassConversion -> ClassHaskellConversion
classHaskellConversion :: ClassHaskellConversion
    -- ^ Conversions to and from Haskell.

    -- NOTE!  When adding new languages here, add the language to
    -- 'classSetConversionToHeap', and 'classSetConversionToGc' as well if the
    -- language supports garbage collection.
  }

-- | Conversion behaviour for a class that is not convertible.
classConversionNone :: ClassConversion
classConversionNone :: ClassConversion
classConversionNone = ClassHaskellConversion -> ClassConversion
ClassConversion ClassHaskellConversion
classHaskellConversionNone

-- | Modifies a class's 'ClassConversion' structure with a given function.
classModifyConversion :: HasCallStack => (ClassConversion -> ClassConversion) -> Class -> Class
classModifyConversion :: HasCallStack =>
(ClassConversion -> ClassConversion) -> Class -> Class
classModifyConversion ClassConversion -> ClassConversion
f Class
cls =
  let cls' :: Class
cls' = Class
cls { classConversion = f $ classConversion cls }
      conv :: ClassConversion
conv = Class -> ClassConversion
classConversion Class
cls'
      haskellConv :: ClassHaskellConversion
haskellConv = ClassConversion -> ClassHaskellConversion
classHaskellConversion ClassConversion
conv
  in case Any
forall a. HasCallStack => a
undefined of
    Any
_ | (Maybe (Generator ()) -> Bool
forall a. Maybe a -> Bool
isJust (ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionToCppFn ClassHaskellConversion
haskellConv) Bool -> Bool -> Bool
||
         Maybe (Generator ()) -> Bool
forall a. Maybe a -> Bool
isJust (ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionFromCppFn ClassHaskellConversion
haskellConv)) Bool -> Bool -> Bool
&&
        Maybe (Generator HsType) -> Bool
forall a. Maybe a -> Bool
isNothing (ClassHaskellConversion -> Maybe (Generator HsType)
classHaskellConversionType ClassHaskellConversion
haskellConv) ->
      ErrorMsg -> Class
forall a. HasCallStack => ErrorMsg -> a
error (ErrorMsg -> Class) -> ErrorMsg -> Class
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"classModifyConversion: " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
cls' ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++
      ErrorMsg
" was given a Haskell-to-C++ or C++-to-Haskell conversion function" ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++
      ErrorMsg
" but no Haskell type.  Please provide a classHaskellConversionType."
    Any
_ -> Class
cls'

-- | Replaces a class's 'ClassConversion' structure.
classSetConversion :: ClassConversion -> Class -> Class
classSetConversion :: ClassConversion -> Class -> Class
classSetConversion ClassConversion
c = HasCallStack =>
(ClassConversion -> ClassConversion) -> Class -> Class
(ClassConversion -> ClassConversion) -> Class -> Class
classModifyConversion ((ClassConversion -> ClassConversion) -> Class -> Class)
-> (ClassConversion -> ClassConversion) -> Class -> Class
forall a b. (a -> b) -> a -> b
$ ClassConversion -> ClassConversion -> ClassConversion
forall a b. a -> b -> a
const ClassConversion
c

-- | Controls how conversions between C++ objects and Haskell values happen in
-- Haskell bindings.
data ClassHaskellConversion = ClassHaskellConversion
  { ClassHaskellConversion -> Maybe (Generator HsType)
classHaskellConversionType :: Maybe (LH.Generator HsType)
    -- ^ Produces the Haskell type that represents a value of the corresponding
    -- C++ class.  This generator may add imports, but must not output code or
    -- add exports.
  , ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionToCppFn :: Maybe (LH.Generator ())
    -- ^ Produces a Haskell expression that evaluates to a function that takes
    -- an value of the type that 'classHaskellConversionType' generates, and
    -- returns a non-const handle for a new C++ object in IO.  The generator
    -- must output code and may add imports, but must not add exports.
    --
    -- If this field is present, then 'classHaskellConversionType' must also be
    -- present.
  , ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionFromCppFn :: Maybe (LH.Generator ())
    -- ^ Produces a Haskell expression that evaluates to a function that takes a
    -- const handle for a C++ object, and returns a value of the type that
    -- 'classHaskellConversionType' generates, in IO.  It should not delete the
    -- handle.  The generator must output code and may add imports, but must not
    -- add exports.
    --
    -- If this field is present, then 'classHaskellConversionType' must also be
    -- present.
  }

-- | Conversion behaviour for a class that is not convertible to or from
-- Haskell.
classHaskellConversionNone :: ClassHaskellConversion
classHaskellConversionNone :: ClassHaskellConversion
classHaskellConversionNone =
  ClassHaskellConversion
  { classHaskellConversionType :: Maybe (Generator HsType)
classHaskellConversionType = Maybe (Generator HsType)
forall a. Maybe a
Nothing
  , classHaskellConversionToCppFn :: Maybe (Generator ())
classHaskellConversionToCppFn = Maybe (Generator ())
forall a. Maybe a
Nothing
  , classHaskellConversionFromCppFn :: Maybe (Generator ())
classHaskellConversionFromCppFn = Maybe (Generator ())
forall a. Maybe a
Nothing
  }

-- | Replaces a class's 'classHaskellConversion' with a given value.
classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class
classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class
classSetHaskellConversion ClassHaskellConversion
conv = HasCallStack =>
(ClassConversion -> ClassConversion) -> Class -> Class
(ClassConversion -> ClassConversion) -> Class -> Class
classModifyConversion ((ClassConversion -> ClassConversion) -> Class -> Class)
-> (ClassConversion -> ClassConversion) -> Class -> Class
forall a b. (a -> b) -> a -> b
$ \ClassConversion
c ->
  ClassConversion
c { classHaskellConversion = conv }

-- | Things that live inside of a class, and have the class's external name
-- prepended to their own in generated code.  With an external name of @\"bar\"@
-- and a class with external name @\"foo\"@, the resulting name will be
-- @\"foo_bar\"@.
--
-- See 'classEntityPrefix' and 'classSetEntityPrefix'.
class IsClassEntity a where
  -- | Extracts the external name of the object, without the class name added.
  classEntityExtNameSuffix :: a -> ExtName

-- | Computes the external name to use in generated code, containing both the
-- class's and object's external names.  This is the concatenation of the
-- class's and entity's external names, separated by an underscore.
classEntityExtName :: IsClassEntity a => Class -> a -> ExtName
classEntityExtName :: forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls a
x =
  HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> ErrorMsg -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (Class -> ExtName
classExtName Class
cls) ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_" ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
fromExtName (a -> ExtName
forall a. IsClassEntity a => a -> ExtName
classEntityExtNameSuffix a
x)

-- | Computes the name under which a class entity is to be exposed in foreign
-- languages.  This is the concatenation of a class's entity prefix, and the
-- external name of the entity.
classEntityForeignName :: IsClassEntity a => Class -> a -> ExtName
classEntityForeignName :: forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls a
x =
  Class -> ExtName -> ExtName
classEntityForeignName' Class
cls (ExtName -> ExtName) -> ExtName -> ExtName
forall a b. (a -> b) -> a -> b
$ a -> ExtName
forall a. IsClassEntity a => a -> ExtName
classEntityExtNameSuffix a
x

-- | Computes the name under which a class entity is to be exposed in foreign
-- languages, given a class and an entity's external name.  The result is the
-- concatenation of a class's entity prefix, and the external name of the
-- entity.
classEntityForeignName' :: Class -> ExtName -> ExtName
classEntityForeignName' :: Class -> ExtName -> ExtName
classEntityForeignName' Class
cls ExtName
extName =
  HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> ErrorMsg -> ExtName
forall a b. (a -> b) -> a -> b
$ Class -> ErrorMsg
classEntityPrefix Class
cls ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
fromExtName ExtName
extName

-- | A C++ entity that belongs to a class.
data ClassEntity =
    CEVar ClassVariable
  | CECtor Ctor
  | CEMethod Method
  | CEProp Prop

-- | Returns all of the names in a 'ClassEntity' within the corresponding
-- 'Class'.
classEntityExtNames :: Class -> ClassEntity -> [ExtName]
classEntityExtNames :: Class -> ClassEntity -> [ExtName]
classEntityExtNames Class
cls ClassEntity
ent = case ClassEntity
ent of
  CEVar ClassVariable
v -> [Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls ClassVariable
v]
  CECtor Ctor
ctor -> [Class -> Ctor -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls Ctor
ctor]
  CEMethod Method
m -> [Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls Method
m]
  CEProp (Prop [Method]
methods) -> (Method -> ExtName) -> [Method] -> [ExtName]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls) [Method]
methods

-- | A C++ member variable.
data ClassVariable = ClassVariable
  { ClassVariable -> ExtName
classVarExtName :: ExtName
    -- ^ The variable's external name.
  , ClassVariable -> ErrorMsg
classVarCName :: String
    -- ^ The variable's C++ name.
  , ClassVariable -> Type
classVarType :: Type
    -- ^ The variable's type.  This may be
    -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is
    -- read-only.
  , ClassVariable -> Staticness
classVarStatic :: Staticness
    -- ^ Whether the variable is static (i.e. whether it exists once in the
    -- class itself and not in each instance).
  , ClassVariable -> Bool
classVarGettable :: Bool
    -- ^ Whether the variable should have an accompanying getter. Note this
    -- exists only for disabling getters on callback variables - as there is
    -- currently no functionality to pass callbacks out of c++
  }

instance Show ClassVariable where
  show :: ClassVariable -> ErrorMsg
show ClassVariable
v =
    [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"<ClassVariable ",
            ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ ClassVariable -> ExtName
classVarExtName ClassVariable
v, ErrorMsg
" ",
            ShowS
forall a. Show a => a -> ErrorMsg
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ClassVariable -> ErrorMsg
classVarCName ClassVariable
v, ErrorMsg
" ",
            Staticness -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Staticness -> ErrorMsg) -> Staticness -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ ClassVariable -> Staticness
classVarStatic ClassVariable
v, ErrorMsg
" ",
            Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Type -> ErrorMsg) -> Type -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ ClassVariable -> Type
classVarType ClassVariable
v, ErrorMsg
">"]

instance IsClassEntity ClassVariable where
  classEntityExtNameSuffix :: ClassVariable -> ExtName
classEntityExtNameSuffix = ClassVariable -> ExtName
classVarExtName

-- | Creates a 'ClassVariable' with full generality and manual name specification.
--
-- The result is wrapped in a 'CEVar'.  For an unwrapped value, use
-- 'makeClassVariable_'.
makeClassVariable :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassEntity
makeClassVariable :: ErrorMsg
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassEntity
makeClassVariable ErrorMsg
cName Maybe ExtName
maybeExtName Type
tp Staticness
static Bool
gettable =
  ClassVariable -> ClassEntity
CEVar (ClassVariable -> ClassEntity) -> ClassVariable -> ClassEntity
forall a b. (a -> b) -> a -> b
$ ErrorMsg
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ ErrorMsg
cName Maybe ExtName
maybeExtName Type
tp Staticness
static Bool
gettable

-- | The unwrapped version of 'makeClassVariable'.
makeClassVariable_ :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ :: ErrorMsg
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ ErrorMsg
cName Maybe ExtName
maybeExtName =
  ExtName -> ErrorMsg -> Type -> Staticness -> Bool -> ClassVariable
ClassVariable (ErrorMsg -> Maybe ExtName -> ExtName
extNameOrString ErrorMsg
cName Maybe ExtName
maybeExtName) ErrorMsg
cName

-- | Creates a 'ClassVariable' for a nonstatic class variable for
-- @class::varName@ whose external name is @class_varName@.
--
-- The result is wrapped in a 'CEVar'.  For an unwrapped value, use
-- 'mkClassVariable_'.
mkClassVariable :: String -> Type -> ClassEntity
mkClassVariable :: ErrorMsg -> Type -> ClassEntity
mkClassVariable = (ClassVariable -> ClassEntity
CEVar (ClassVariable -> ClassEntity)
-> (Type -> ClassVariable) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> ClassVariable) -> Type -> ClassEntity)
-> (ErrorMsg -> Type -> ClassVariable)
-> ErrorMsg
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> Type -> ClassVariable
mkClassVariable_

-- | The unwrapped version of 'mkClassVariable'.
mkClassVariable_ :: String -> Type -> ClassVariable
mkClassVariable_ :: ErrorMsg -> Type -> ClassVariable
mkClassVariable_ ErrorMsg
cName Type
t = ErrorMsg
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ ErrorMsg
cName Maybe ExtName
forall a. Maybe a
Nothing Type
t Staticness
Nonstatic Bool
True

-- | Same as 'mkClassVariable', but returns a static variable instead.
--
-- The result is wrapped in a 'CEVar'.  For an unwrapped value, use
-- 'mkStaticClassVariable_'.
mkStaticClassVariable :: String -> Type -> ClassEntity
mkStaticClassVariable :: ErrorMsg -> Type -> ClassEntity
mkStaticClassVariable = (ClassVariable -> ClassEntity
CEVar (ClassVariable -> ClassEntity)
-> (Type -> ClassVariable) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> ClassVariable) -> Type -> ClassEntity)
-> (ErrorMsg -> Type -> ClassVariable)
-> ErrorMsg
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> Type -> ClassVariable
mkStaticClassVariable_

-- | The unwrapped version of 'mkStaticClassVariable'.
mkStaticClassVariable_ :: String -> Type -> ClassVariable
mkStaticClassVariable_ :: ErrorMsg -> Type -> ClassVariable
mkStaticClassVariable_ ErrorMsg
cName Type
t = ErrorMsg
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ ErrorMsg
cName Maybe ExtName
forall a. Maybe a
Nothing Type
t Staticness
Static Bool
True

-- | Returns the external name of the getter function for the class variable.
classVarGetterExtName :: Class -> ClassVariable -> ExtName
classVarGetterExtName :: Class -> ClassVariable -> ExtName
classVarGetterExtName Class
cls ClassVariable
v =
  HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> ErrorMsg -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls ClassVariable
v) ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_get"

-- | Returns the foreign name of the getter function for the class variable.
classVarGetterForeignName :: Class -> ClassVariable -> ExtName
classVarGetterForeignName :: Class -> ClassVariable -> ExtName
classVarGetterForeignName Class
cls ClassVariable
v =
  HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> ErrorMsg -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls ClassVariable
v) ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_get"

-- | Returns the external name of the setter function for the class variable.
classVarSetterExtName :: Class -> ClassVariable -> ExtName
classVarSetterExtName :: Class -> ClassVariable -> ExtName
classVarSetterExtName Class
cls ClassVariable
v =
  HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> ErrorMsg -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls ClassVariable
v) ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_set"

-- | Returns the foreign name of the setter function for the class variable.
classVarSetterForeignName :: Class -> ClassVariable -> ExtName
classVarSetterForeignName :: Class -> ClassVariable -> ExtName
classVarSetterForeignName Class
cls ClassVariable
v =
  HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> ErrorMsg -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls ClassVariable
v) ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_set"

-- | A C++ class constructor declaration.
data Ctor = Ctor
  { Ctor -> ExtName
ctorExtName :: ExtName
    -- ^ The constructor's external name.
  , Ctor -> [Parameter]
ctorParams :: [Parameter]
    -- ^ The constructor's parameters.
  , Ctor -> ExceptionHandlers
ctorExceptionHandlers :: ExceptionHandlers
    -- ^ Exceptions that the constructor may throw.
  }

instance Show Ctor where
  show :: Ctor -> ErrorMsg
show Ctor
ctor = [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"<Ctor ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Ctor -> ExtName
ctorExtName Ctor
ctor), ErrorMsg
" ", [Parameter] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Ctor -> [Parameter]
ctorParams Ctor
ctor), ErrorMsg
">"]

instance HandlesExceptions Ctor where
  getExceptionHandlers :: Ctor -> ExceptionHandlers
getExceptionHandlers = Ctor -> ExceptionHandlers
ctorExceptionHandlers
  modifyExceptionHandlers :: (ExceptionHandlers -> ExceptionHandlers) -> Ctor -> Ctor
modifyExceptionHandlers ExceptionHandlers -> ExceptionHandlers
f Ctor
ctor = Ctor
ctor { ctorExceptionHandlers = f $ ctorExceptionHandlers ctor }

instance IsClassEntity Ctor where
  classEntityExtNameSuffix :: Ctor -> ExtName
classEntityExtNameSuffix = Ctor -> ExtName
ctorExtName

-- | Creates a 'Ctor' with full generality.
--
-- The result is wrapped in a 'CECtor'.  For an unwrapped value, use
-- 'makeCtor_'.
makeCtor :: IsParameter p => ExtName -> [p] -> ClassEntity
makeCtor :: forall p. IsParameter p => ExtName -> [p] -> ClassEntity
makeCtor = (Ctor -> ClassEntity
CECtor (Ctor -> ClassEntity) -> ([p] -> Ctor) -> [p] -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Ctor) -> [p] -> ClassEntity)
-> (ExtName -> [p] -> Ctor) -> ExtName -> [p] -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtName -> [p] -> Ctor
forall p. IsParameter p => ExtName -> [p] -> Ctor
makeCtor_

-- | The unwrapped version of 'makeCtor'.
makeCtor_ :: IsParameter p => ExtName -> [p] -> Ctor
makeCtor_ :: forall p. IsParameter p => ExtName -> [p] -> Ctor
makeCtor_ ExtName
extName [p]
params = ExtName -> [Parameter] -> ExceptionHandlers -> Ctor
Ctor ExtName
extName ((p -> Parameter) -> [p] -> [Parameter]
forall a b. (a -> b) -> [a] -> [b]
map p -> Parameter
forall a. IsParameter a => a -> Parameter
toParameter [p]
params) ExceptionHandlers
forall a. Monoid a => a
mempty

-- | @mkCtor name@ creates a 'Ctor' whose external name is @className_name@.
--
-- The result is wrapped in a 'CECtor'.  For an unwrapped value, use
-- 'makeCtor_'.
mkCtor :: IsParameter p => String -> [p] -> ClassEntity
mkCtor :: forall p. IsParameter p => ErrorMsg -> [p] -> ClassEntity
mkCtor = (Ctor -> ClassEntity
CECtor (Ctor -> ClassEntity) -> ([p] -> Ctor) -> [p] -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Ctor) -> [p] -> ClassEntity)
-> (ErrorMsg -> [p] -> Ctor) -> ErrorMsg -> [p] -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> [p] -> Ctor
forall p. IsParameter p => ErrorMsg -> [p] -> Ctor
mkCtor_

-- | The unwrapped version of 'mkCtor'.
mkCtor_ :: IsParameter p => String -> [p] -> Ctor
mkCtor_ :: forall p. IsParameter p => ErrorMsg -> [p] -> Ctor
mkCtor_ ErrorMsg
extName [p]
params = ExtName -> [Parameter] -> Ctor
forall p. IsParameter p => ExtName -> [p] -> Ctor
makeCtor_ (HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName ErrorMsg
extName) ((p -> Parameter) -> [p] -> [Parameter]
forall a b. (a -> b) -> [a] -> [b]
map p -> Parameter
forall a. IsParameter a => a -> Parameter
toParameter [p]
params)

-- | Searches a class for a copy constructor, returning it if found.
classFindCopyCtor :: Class -> Maybe Ctor
classFindCopyCtor :: Class -> Maybe Ctor
classFindCopyCtor Class
cls = case (Ctor -> Maybe Ctor) -> [Ctor] -> [Ctor]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Ctor -> Maybe Ctor
check ([Ctor] -> [Ctor]) -> [Ctor] -> [Ctor]
forall a b. (a -> b) -> a -> b
$ Class -> [Ctor]
classCtors Class
cls of
  [Ctor
ctor] -> Ctor -> Maybe Ctor
forall a. a -> Maybe a
Just Ctor
ctor
  [Ctor]
_ -> Maybe Ctor
forall a. Maybe a
Nothing
  where check :: Ctor -> Maybe Ctor
check Ctor
ctor =
          let paramTypes :: [Type]
paramTypes = (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type
stripConst (Type -> Type) -> (Parameter -> Type) -> Parameter -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
normalizeType (Type -> Type) -> (Parameter -> Type) -> Parameter -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parameter -> Type
parameterType) ([Parameter] -> [Type]) -> [Parameter] -> [Type]
forall a b. (a -> b) -> a -> b
$ Ctor -> [Parameter]
ctorParams Ctor
ctor
          in if [Type]
paramTypes [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Class -> Type
Internal_TObj Class
cls] Bool -> Bool -> Bool
||
                [Type]
paramTypes [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Type -> Type
Internal_TRef (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
Internal_TConst (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
Internal_TObj Class
cls]
          then Ctor -> Maybe Ctor
forall a. a -> Maybe a
Just Ctor
ctor
          else Maybe Ctor
forall a. Maybe a
Nothing

-- | A C++ class method declaration.
--
-- Any operator function that can be written as a method may have its binding be
-- written either as part of the associated class or as a separate entity,
-- independently of how the function is declared in C++.
data Method = Method
  { Method -> MethodImpl
methodImpl :: MethodImpl
    -- ^ The underlying code that the binding calls.
  , Method -> ExtName
methodExtName :: ExtName
    -- ^ The method's external name.
  , Method -> MethodApplicability
methodApplicability :: MethodApplicability
    -- ^ How the method is associated to its class.
  , Method -> Purity
methodPurity :: Purity
    -- ^ Whether the method is pure.
  , Method -> [Parameter]
methodParams :: [Parameter]
    -- ^ The method's parameters.
  , Method -> Type
methodReturn :: Type
    -- ^ The method's return type.
  , Method -> ExceptionHandlers
methodExceptionHandlers :: ExceptionHandlers
    -- ^ Exceptions that the method might throw.
  }

instance Show Method where
  show :: Method -> ErrorMsg
show Method
method =
    [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"<Method ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Method -> ExtName
methodExtName Method
method), ErrorMsg
" ",
            case Method -> MethodImpl
methodImpl Method
method of
              RealMethod FnName ErrorMsg
name -> FnName ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show FnName ErrorMsg
name
              FnMethod FnName Identifier
name -> FnName Identifier -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show FnName Identifier
name, ErrorMsg
" ",
            MethodApplicability -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Method -> MethodApplicability
methodApplicability Method
method), ErrorMsg
" ",
            Purity -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Method -> Purity
methodPurity Method
method), ErrorMsg
" ",
            [Parameter] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Method -> [Parameter]
methodParams Method
method), ErrorMsg
" ",
            Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Method -> Type
methodReturn Method
method), ErrorMsg
">"]

instance HandlesExceptions Method where
  getExceptionHandlers :: Method -> ExceptionHandlers
getExceptionHandlers = Method -> ExceptionHandlers
methodExceptionHandlers

  modifyExceptionHandlers :: (ExceptionHandlers -> ExceptionHandlers) -> Method -> Method
modifyExceptionHandlers ExceptionHandlers -> ExceptionHandlers
f Method
method =
    Method
method { methodExceptionHandlers = f $ methodExceptionHandlers method }

instance IsClassEntity Method where
  classEntityExtNameSuffix :: Method -> ExtName
classEntityExtNameSuffix = Method -> ExtName
methodExtName

-- | The C++ code to which a 'Method' is bound.
data MethodImpl =
  RealMethod (FnName String)
  -- ^ The 'Method' is bound to an actual class method.
  | FnMethod (FnName Identifier)
    -- ^ The 'Method' is bound to a wrapper function.  When wrapping a method
    -- with another function, this is preferrable to just using a
    -- 'Foreign.Hoppy.Generator.Spec.Function.Function' binding because a method
    -- will still appear to be part of the class in foreign bindings.
  deriving (MethodImpl -> MethodImpl -> Bool
(MethodImpl -> MethodImpl -> Bool)
-> (MethodImpl -> MethodImpl -> Bool) -> Eq MethodImpl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MethodImpl -> MethodImpl -> Bool
== :: MethodImpl -> MethodImpl -> Bool
$c/= :: MethodImpl -> MethodImpl -> Bool
/= :: MethodImpl -> MethodImpl -> Bool
Eq, Int -> MethodImpl -> ShowS
[MethodImpl] -> ShowS
MethodImpl -> ErrorMsg
(Int -> MethodImpl -> ShowS)
-> (MethodImpl -> ErrorMsg)
-> ([MethodImpl] -> ShowS)
-> Show MethodImpl
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MethodImpl -> ShowS
showsPrec :: Int -> MethodImpl -> ShowS
$cshow :: MethodImpl -> ErrorMsg
show :: MethodImpl -> ErrorMsg
$cshowList :: [MethodImpl] -> ShowS
showList :: [MethodImpl] -> ShowS
Show)

-- | How a method is associated to its class.  A method may be static, const, or
-- neither (a regular method).
data MethodApplicability = MNormal | MStatic | MConst
                         deriving (MethodApplicability
MethodApplicability
-> MethodApplicability -> Bounded MethodApplicability
forall a. a -> a -> Bounded a
$cminBound :: MethodApplicability
minBound :: MethodApplicability
$cmaxBound :: MethodApplicability
maxBound :: MethodApplicability
Bounded, Int -> MethodApplicability
MethodApplicability -> Int
MethodApplicability -> [MethodApplicability]
MethodApplicability -> MethodApplicability
MethodApplicability -> MethodApplicability -> [MethodApplicability]
MethodApplicability
-> MethodApplicability
-> MethodApplicability
-> [MethodApplicability]
(MethodApplicability -> MethodApplicability)
-> (MethodApplicability -> MethodApplicability)
-> (Int -> MethodApplicability)
-> (MethodApplicability -> Int)
-> (MethodApplicability -> [MethodApplicability])
-> (MethodApplicability
    -> MethodApplicability -> [MethodApplicability])
-> (MethodApplicability
    -> MethodApplicability -> [MethodApplicability])
-> (MethodApplicability
    -> MethodApplicability
    -> MethodApplicability
    -> [MethodApplicability])
-> Enum MethodApplicability
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: MethodApplicability -> MethodApplicability
succ :: MethodApplicability -> MethodApplicability
$cpred :: MethodApplicability -> MethodApplicability
pred :: MethodApplicability -> MethodApplicability
$ctoEnum :: Int -> MethodApplicability
toEnum :: Int -> MethodApplicability
$cfromEnum :: MethodApplicability -> Int
fromEnum :: MethodApplicability -> Int
$cenumFrom :: MethodApplicability -> [MethodApplicability]
enumFrom :: MethodApplicability -> [MethodApplicability]
$cenumFromThen :: MethodApplicability -> MethodApplicability -> [MethodApplicability]
enumFromThen :: MethodApplicability -> MethodApplicability -> [MethodApplicability]
$cenumFromTo :: MethodApplicability -> MethodApplicability -> [MethodApplicability]
enumFromTo :: MethodApplicability -> MethodApplicability -> [MethodApplicability]
$cenumFromThenTo :: MethodApplicability
-> MethodApplicability
-> MethodApplicability
-> [MethodApplicability]
enumFromThenTo :: MethodApplicability
-> MethodApplicability
-> MethodApplicability
-> [MethodApplicability]
Enum, MethodApplicability -> MethodApplicability -> Bool
(MethodApplicability -> MethodApplicability -> Bool)
-> (MethodApplicability -> MethodApplicability -> Bool)
-> Eq MethodApplicability
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MethodApplicability -> MethodApplicability -> Bool
== :: MethodApplicability -> MethodApplicability -> Bool
$c/= :: MethodApplicability -> MethodApplicability -> Bool
/= :: MethodApplicability -> MethodApplicability -> Bool
Eq, Int -> MethodApplicability -> ShowS
[MethodApplicability] -> ShowS
MethodApplicability -> ErrorMsg
(Int -> MethodApplicability -> ShowS)
-> (MethodApplicability -> ErrorMsg)
-> ([MethodApplicability] -> ShowS)
-> Show MethodApplicability
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MethodApplicability -> ShowS
showsPrec :: Int -> MethodApplicability -> ShowS
$cshow :: MethodApplicability -> ErrorMsg
show :: MethodApplicability -> ErrorMsg
$cshowList :: [MethodApplicability] -> ShowS
showList :: [MethodApplicability] -> ShowS
Show)

-- | Whether or not a method is static.
data Staticness = Nonstatic | Static
               deriving (Staticness
Staticness -> Staticness -> Bounded Staticness
forall a. a -> a -> Bounded a
$cminBound :: Staticness
minBound :: Staticness
$cmaxBound :: Staticness
maxBound :: Staticness
Bounded, Int -> Staticness
Staticness -> Int
Staticness -> [Staticness]
Staticness -> Staticness
Staticness -> Staticness -> [Staticness]
Staticness -> Staticness -> Staticness -> [Staticness]
(Staticness -> Staticness)
-> (Staticness -> Staticness)
-> (Int -> Staticness)
-> (Staticness -> Int)
-> (Staticness -> [Staticness])
-> (Staticness -> Staticness -> [Staticness])
-> (Staticness -> Staticness -> [Staticness])
-> (Staticness -> Staticness -> Staticness -> [Staticness])
-> Enum Staticness
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Staticness -> Staticness
succ :: Staticness -> Staticness
$cpred :: Staticness -> Staticness
pred :: Staticness -> Staticness
$ctoEnum :: Int -> Staticness
toEnum :: Int -> Staticness
$cfromEnum :: Staticness -> Int
fromEnum :: Staticness -> Int
$cenumFrom :: Staticness -> [Staticness]
enumFrom :: Staticness -> [Staticness]
$cenumFromThen :: Staticness -> Staticness -> [Staticness]
enumFromThen :: Staticness -> Staticness -> [Staticness]
$cenumFromTo :: Staticness -> Staticness -> [Staticness]
enumFromTo :: Staticness -> Staticness -> [Staticness]
$cenumFromThenTo :: Staticness -> Staticness -> Staticness -> [Staticness]
enumFromThenTo :: Staticness -> Staticness -> Staticness -> [Staticness]
Enum, Staticness -> Staticness -> Bool
(Staticness -> Staticness -> Bool)
-> (Staticness -> Staticness -> Bool) -> Eq Staticness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Staticness -> Staticness -> Bool
== :: Staticness -> Staticness -> Bool
$c/= :: Staticness -> Staticness -> Bool
/= :: Staticness -> Staticness -> Bool
Eq, Int -> Staticness -> ShowS
[Staticness] -> ShowS
Staticness -> ErrorMsg
(Int -> Staticness -> ShowS)
-> (Staticness -> ErrorMsg)
-> ([Staticness] -> ShowS)
-> Show Staticness
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Staticness -> ShowS
showsPrec :: Int -> Staticness -> ShowS
$cshow :: Staticness -> ErrorMsg
show :: Staticness -> ErrorMsg
$cshowList :: [Staticness] -> ShowS
showList :: [Staticness] -> ShowS
Show)

-- | Returns the constness of a method, based on its 'methodApplicability'.
methodConst :: Method -> Constness
methodConst :: Method -> Constness
methodConst Method
method = case Method -> MethodApplicability
methodApplicability Method
method of
  MethodApplicability
MConst -> Constness
Const
  MethodApplicability
_ -> Constness
Nonconst

-- | Returns the staticness of a method, based on its 'methodApplicability'.
methodStatic :: Method -> Staticness
methodStatic :: Method -> Staticness
methodStatic Method
method = case Method -> MethodApplicability
methodApplicability Method
method of
  MethodApplicability
MStatic -> Staticness
Static
  MethodApplicability
_ -> Staticness
Nonstatic

-- | Creates a 'Method' with full generality and manual name specification.
--
-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use
-- 'makeMethod_'.
makeMethod :: (IsFnName String name, IsParameter p)
           => name  -- ^ The C++ name of the method.
           -> ExtName  -- ^ The external name of the method.
           -> MethodApplicability
           -> Purity
           -> [p]  -- ^ Parameter types.
           -> Type  -- ^ Return type.
           -> ClassEntity
makeMethod :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
makeMethod = (((((Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> (Type -> Method) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Method) -> Type -> ClassEntity)
-> ([p] -> Type -> Method) -> [p] -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Type -> Method) -> [p] -> Type -> ClassEntity)
-> (Purity -> [p] -> Type -> Method)
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Purity -> [p] -> Type -> Method)
 -> Purity -> [p] -> Type -> ClassEntity)
-> (MethodApplicability -> Purity -> [p] -> Type -> Method)
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((MethodApplicability -> Purity -> [p] -> Type -> Method)
 -> MethodApplicability -> Purity -> [p] -> Type -> ClassEntity)
-> (ExtName
    -> MethodApplicability -> Purity -> [p] -> Type -> Method)
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ExtName
  -> MethodApplicability -> Purity -> [p] -> Type -> Method)
 -> ExtName
 -> MethodApplicability
 -> Purity
 -> [p]
 -> Type
 -> ClassEntity)
-> (name
    -> ExtName
    -> MethodApplicability
    -> Purity
    -> [p]
    -> Type
    -> Method)
-> name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod_

-- | The unwrapped version of 'makeMethod'.
makeMethod_ :: (IsFnName String name, IsParameter p)
            => name
            -> ExtName
            -> MethodApplicability
            -> Purity
            -> [p]
            -> Type
            -> Method
makeMethod_ :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod_ name
cName ExtName
extName MethodApplicability
appl Purity
purity [p]
paramTypes Type
retType =
  MethodImpl
-> ExtName
-> MethodApplicability
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Method
Method (FnName ErrorMsg -> MethodImpl
RealMethod (FnName ErrorMsg -> MethodImpl) -> FnName ErrorMsg -> MethodImpl
forall a b. (a -> b) -> a -> b
$ name -> FnName ErrorMsg
forall t a. IsFnName t a => a -> FnName t
toFnName name
cName) ExtName
extName MethodApplicability
appl Purity
purity
         ([p] -> [Parameter]
forall a. IsParameter a => [a] -> [Parameter]
toParameters [p]
paramTypes) Type
retType ExceptionHandlers
forall a. Monoid a => a
mempty

-- | Creates a 'Method' that is in fact backed by a C++ non-member function (a
-- la 'Foreign.Hoppy.Generator.Spec.Function.makeFn'), but appears to be a
-- regular method.  This is useful for wrapping a method on the C++ side when
-- its arguments aren't right for binding directly.
--
-- A @this@ pointer parameter is __not__ automatically added to the parameter
-- list for non-static methods created with @makeFnMethod@.
--
-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use
-- 'makeFnMethod_'.
makeFnMethod :: (IsFnName Identifier name, IsParameter p)
             => name
             -> String
             -> MethodApplicability
             -> Purity
             -> [p]
             -> Type
             -> ClassEntity
makeFnMethod :: forall name p.
(IsFnName Identifier name, IsParameter p) =>
name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
makeFnMethod = (((((Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> (Type -> Method) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Method) -> Type -> ClassEntity)
-> ([p] -> Type -> Method) -> [p] -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Type -> Method) -> [p] -> Type -> ClassEntity)
-> (Purity -> [p] -> Type -> Method)
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Purity -> [p] -> Type -> Method)
 -> Purity -> [p] -> Type -> ClassEntity)
-> (MethodApplicability -> Purity -> [p] -> Type -> Method)
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((MethodApplicability -> Purity -> [p] -> Type -> Method)
 -> MethodApplicability -> Purity -> [p] -> Type -> ClassEntity)
-> (ErrorMsg
    -> MethodApplicability -> Purity -> [p] -> Type -> Method)
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ErrorMsg
  -> MethodApplicability -> Purity -> [p] -> Type -> Method)
 -> ErrorMsg
 -> MethodApplicability
 -> Purity
 -> [p]
 -> Type
 -> ClassEntity)
-> (name
    -> ErrorMsg
    -> MethodApplicability
    -> Purity
    -> [p]
    -> Type
    -> Method)
-> name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall name p.
(IsFnName Identifier name, IsParameter p) =>
name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeFnMethod_

-- | The unwrapped version of 'makeFnMethod'.
makeFnMethod_ :: (IsFnName Identifier name, IsParameter p)
              => name
              -> String
              -> MethodApplicability
              -> Purity
              -> [p]
              -> Type
              -> Method
makeFnMethod_ :: forall name p.
(IsFnName Identifier name, IsParameter p) =>
name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeFnMethod_ name
cName ErrorMsg
foreignName MethodApplicability
appl Purity
purity [p]
paramTypes Type
retType =
  MethodImpl
-> ExtName
-> MethodApplicability
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Method
Method (FnName Identifier -> MethodImpl
FnMethod (FnName Identifier -> MethodImpl)
-> FnName Identifier -> MethodImpl
forall a b. (a -> b) -> a -> b
$ name -> FnName Identifier
forall t a. IsFnName t a => a -> FnName t
toFnName name
cName) (HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName ErrorMsg
foreignName)
         MethodApplicability
appl Purity
purity ([p] -> [Parameter]
forall a. IsParameter a => [a] -> [Parameter]
toParameters [p]
paramTypes) Type
retType ExceptionHandlers
forall a. Monoid a => a
mempty

-- | This function is internal.
--
-- Creates a method similar to 'makeMethod', but with automatic naming.  The
-- method's external name will be @className ++ \"_\" ++ cppMethodName@.  If the
-- method name is a 'FnOp' then the 'operatorPreferredExtName' will be appeneded
-- to the class name.
--
-- For creating multiple bindings to a method, see @makeMethod''@.
makeMethod' :: (IsFnName String name, IsParameter p)
            => name  -- ^ The C++ name of the method.
            -> MethodApplicability
            -> Purity
            -> [p]  -- ^ Parameter types.
            -> Type  -- ^ Return type.
            -> Method
makeMethod' :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod' name
name = FnName ErrorMsg
-> Maybe ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall p.
(HasCallStack, IsParameter p) =>
FnName ErrorMsg
-> Maybe ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod''' (name -> FnName ErrorMsg
forall t a. IsFnName t a => a -> FnName t
toFnName name
name) Maybe ErrorMsg
forall a. Maybe a
Nothing

-- | This function is internal.
--
-- Creates a method similar to @makeMethod'@, but with an custom string that
-- will be appended to the class name to form the method's external name.  This
-- is useful for making multiple bindings to a method, e.g. for overloading and
-- optional arguments.
makeMethod'' :: (IsFnName String name, IsParameter p)
             => name  -- ^ The C++ name of the method.
             -> String  -- ^ A foreign name for the method.
             -> MethodApplicability
             -> Purity
             -> [p]  -- ^ Parameter types.
             -> Type  -- ^ Return type.
             -> Method
makeMethod'' :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod'' name
name ErrorMsg
foreignName = FnName ErrorMsg
-> Maybe ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall p.
(HasCallStack, IsParameter p) =>
FnName ErrorMsg
-> Maybe ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod''' (name -> FnName ErrorMsg
forall t a. IsFnName t a => a -> FnName t
toFnName name
name) (Maybe ErrorMsg
 -> MethodApplicability -> Purity -> [p] -> Type -> Method)
-> Maybe ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
foreignName

-- | The implementation of @makeMethod'@ and @makeMethod''@.
makeMethod''' :: (HasCallStack, IsParameter p)
              => FnName String  -- ^ The C++ name of the method.
              -> Maybe String  -- ^ A foreign name for the method.
              -> MethodApplicability
              -> Purity
              -> [p]  -- ^ Parameter types.
              -> Type  -- ^ Return type.
              -> Method
makeMethod''' :: forall p.
(HasCallStack, IsParameter p) =>
FnName ErrorMsg
-> Maybe ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod''' (FnName ErrorMsg
"") Maybe ErrorMsg
maybeForeignName MethodApplicability
_ Purity
_ [p]
paramTypes Type
retType =
  ErrorMsg -> Method
forall a. HasCallStack => ErrorMsg -> a
error (ErrorMsg -> Method) -> ErrorMsg -> Method
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"makeMethod''': Given an empty method name with foreign name ",
                  Maybe ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Maybe ErrorMsg
maybeForeignName, ErrorMsg
", parameter types ", [p] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show [p]
paramTypes,
                  ErrorMsg
", and return type ", Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
retType, ErrorMsg
"."]
makeMethod''' FnName ErrorMsg
name (Just ErrorMsg
"") MethodApplicability
_ Purity
_ [p]
paramTypes Type
retType =
  ErrorMsg -> Method
forall a. HasCallStack => ErrorMsg -> a
error (ErrorMsg -> Method) -> ErrorMsg -> Method
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"makeMethod''': Given an empty foreign name with method ",
                  FnName ErrorMsg -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show FnName ErrorMsg
name, ErrorMsg
", parameter types ", [p] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show [p]
paramTypes, ErrorMsg
", and return type ",
                  Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Type
retType, ErrorMsg
"."]
makeMethod''' FnName ErrorMsg
name Maybe ErrorMsg
maybeForeignName MethodApplicability
appl Purity
purity [p]
paramTypes Type
retType =
  let extName :: ExtName
extName = (ExtName -> Maybe ExtName -> ExtName)
-> Maybe ExtName -> ExtName -> ExtName
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExtName -> Maybe ExtName -> ExtName
forall a. a -> Maybe a -> a
fromMaybe (HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> Maybe ErrorMsg -> Maybe ExtName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ErrorMsg
maybeForeignName) (ExtName -> ExtName) -> ExtName -> ExtName
forall a b. (a -> b) -> a -> b
$ case FnName ErrorMsg
name of
        FnName ErrorMsg
s -> HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName ErrorMsg
s
        FnOp Operator
op -> HasCallStack => Operator -> ExtName
Operator -> ExtName
operatorPreferredExtName Operator
op
  in FnName ErrorMsg
-> ExtName
-> MethodApplicability
-> Purity
-> [Parameter]
-> Type
-> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod_ FnName ErrorMsg
name ExtName
extName MethodApplicability
appl Purity
purity ([p] -> [Parameter]
forall a. IsParameter a => [a] -> [Parameter]
toParameters [p]
paramTypes) Type
retType

-- | Creates a nonconst, nonstatic 'Method' for @class::methodName@ and whose
-- external name is @class_methodName@.  If the name is an operator, then the
-- 'operatorPreferredExtName' will be used in the external name.
--
-- For creating multiple bindings to a method, see 'mkMethod''.
--
-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use
-- 'mkMethod_'.
mkMethod :: (IsFnName String name, IsParameter p)
         => name  -- ^ The C++ name of the method.
         -> [p]  -- ^ Parameter types.
         -> Type  -- ^ Return type.
         -> ClassEntity
mkMethod :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> ClassEntity
mkMethod = ((Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> (Type -> Method) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Method) -> Type -> ClassEntity)
-> ([p] -> Type -> Method) -> [p] -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Type -> Method) -> [p] -> Type -> ClassEntity)
-> (name -> [p] -> Type -> Method)
-> name
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_

-- | The unwrapped version of 'mkMethod'.
mkMethod_ :: (IsFnName String name, IsParameter p)
          => name
          -> [p]
          -> Type
          -> Method
mkMethod_ :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_ name
name = name -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod' name
name MethodApplicability
MNormal Purity
Nonpure

-- | Creates a nonconst, nonstatic 'Method' for method @class::methodName@ and
-- whose external name is @class_methodName@.  This enables multiple 'Method's
-- with different foreign names (and hence different external names) to bind to
-- the same method, e.g. to make use of optional arguments or overloading.  See
-- 'mkMethod' for a simpler form.
--
-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use
-- 'mkMethod'_'.
mkMethod' :: (IsFnName String name, IsParameter p)
          => name  -- ^ The C++ name of the method.
          -> String  -- ^ A foreign name for the method.
          -> [p]  -- ^ Parameter types.
          -> Type  -- ^ Return type.
          -> ClassEntity
mkMethod' :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> ClassEntity
mkMethod' = (((Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> (Type -> Method) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Method) -> Type -> ClassEntity)
-> ([p] -> Type -> Method) -> [p] -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Type -> Method) -> [p] -> Type -> ClassEntity)
-> (ErrorMsg -> [p] -> Type -> Method)
-> ErrorMsg
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ErrorMsg -> [p] -> Type -> Method)
 -> ErrorMsg -> [p] -> Type -> ClassEntity)
-> (name -> ErrorMsg -> [p] -> Type -> Method)
-> name
-> ErrorMsg
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> ErrorMsg -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> Method
mkMethod'_

-- | The unwrapped version of 'mkMethod''.
mkMethod'_ :: (IsFnName String name, IsParameter p)
           => name
           -> String
           -> [p]
           -> Type
           -> Method
mkMethod'_ :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> Method
mkMethod'_ name
cName ErrorMsg
foreignName = name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod'' name
cName ErrorMsg
foreignName MethodApplicability
MNormal Purity
Nonpure

-- | Same as 'mkMethod', but returns an 'MConst' method.
--
-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use
-- 'mkConstMethod_'.
mkConstMethod :: (IsFnName String name, IsParameter p)
              => name
              -> [p]
              -> Type
              -> ClassEntity
mkConstMethod :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> ClassEntity
mkConstMethod = ((Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> (Type -> Method) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Method) -> Type -> ClassEntity)
-> ([p] -> Type -> Method) -> [p] -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Type -> Method) -> [p] -> Type -> ClassEntity)
-> (name -> [p] -> Type -> Method)
-> name
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_

-- | The unwrapped version of 'mkConstMethod'.
mkConstMethod_ :: (IsFnName String name, IsParameter p)
               => name
               -> [p]
               -> Type
               -> Method
mkConstMethod_ :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_ name
name = name -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod' name
name MethodApplicability
MConst Purity
Nonpure

-- | Same as 'mkMethod'', but returns an 'MConst' method.
--
-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use
-- 'mkConstMethod'_'.
mkConstMethod' :: (IsFnName String name, IsParameter p)
               => name
               -> String
               -> [p]
               -> Type
               -> ClassEntity
mkConstMethod' :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> ClassEntity
mkConstMethod' = (((Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> (Type -> Method) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Method) -> Type -> ClassEntity)
-> ([p] -> Type -> Method) -> [p] -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Type -> Method) -> [p] -> Type -> ClassEntity)
-> (ErrorMsg -> [p] -> Type -> Method)
-> ErrorMsg
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ErrorMsg -> [p] -> Type -> Method)
 -> ErrorMsg -> [p] -> Type -> ClassEntity)
-> (name -> ErrorMsg -> [p] -> Type -> Method)
-> name
-> ErrorMsg
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> ErrorMsg -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> Method
mkConstMethod'_

-- | The unwrapped version of 'mkConstMethod''.
mkConstMethod'_ :: (IsFnName String name, IsParameter p)
                => name
                -> String
                -> [p]
                -> Type
                -> Method
mkConstMethod'_ :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> Method
mkConstMethod'_ name
cName ErrorMsg
foreignName = name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod'' name
cName ErrorMsg
foreignName MethodApplicability
MConst Purity
Nonpure

-- | Same as 'mkMethod', but returns an 'MStatic' method.
--
-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use
-- 'mkStaticMethod_'.
mkStaticMethod :: (IsFnName String name, IsParameter p)
               => name
               -> [p]
               -> Type
               -> ClassEntity
mkStaticMethod :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> ClassEntity
mkStaticMethod = ((Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> (Type -> Method) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Method) -> Type -> ClassEntity)
-> ([p] -> Type -> Method) -> [p] -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Type -> Method) -> [p] -> Type -> ClassEntity)
-> (name -> [p] -> Type -> Method)
-> name
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkStaticMethod_

-- | The unwrapped version of 'mkStaticMethod'.
mkStaticMethod_ :: (IsFnName String name, IsParameter p)
                => name
                -> [p]
                -> Type
                -> Method
mkStaticMethod_ :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkStaticMethod_ name
name = name -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod' name
name MethodApplicability
MStatic Purity
Nonpure

-- | Same as 'mkMethod'', but returns an 'MStatic' method.
--
-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use
-- 'mkStaticMethod'_'.
mkStaticMethod' :: (IsFnName String name, IsParameter p)
                => name
                -> String
                -> [p]
                -> Type
                -> ClassEntity
mkStaticMethod' :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> ClassEntity
mkStaticMethod' = (((Method -> ClassEntity
CEMethod (Method -> ClassEntity) -> (Type -> Method) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Method) -> Type -> ClassEntity)
-> ([p] -> Type -> Method) -> [p] -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([p] -> Type -> Method) -> [p] -> Type -> ClassEntity)
-> (ErrorMsg -> [p] -> Type -> Method)
-> ErrorMsg
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ErrorMsg -> [p] -> Type -> Method)
 -> ErrorMsg -> [p] -> Type -> ClassEntity)
-> (name -> ErrorMsg -> [p] -> Type -> Method)
-> name
-> ErrorMsg
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> ErrorMsg -> [p] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> Method
mkStaticMethod'_

-- | The unwrapped version of 'mkStaticMethod''.
mkStaticMethod'_ :: (IsFnName String name, IsParameter p)
                 => name
                 -> String
                 -> [p]
                 -> Type
                 -> Method
mkStaticMethod'_ :: forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> ErrorMsg -> [p] -> Type -> Method
mkStaticMethod'_ name
cName ErrorMsg
foreignName = name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name
-> ErrorMsg
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod'' name
cName ErrorMsg
foreignName MethodApplicability
MStatic Purity
Nonpure

-- | A \"property\" getter/setter pair.
newtype Prop = Prop [Method]

-- | Creates a getter/setter binding pair for methods:
--
-- > T foo() const
-- > void setFoo(T)
--
-- The result is wrapped in a 'CEProp'.  For an unwrapped value, use
-- 'mkProp_'.
mkProp :: String -> Type -> ClassEntity
mkProp :: ErrorMsg -> Type -> ClassEntity
mkProp = (Prop -> ClassEntity
CEProp (Prop -> ClassEntity) -> (Type -> Prop) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Prop) -> Type -> ClassEntity)
-> (ErrorMsg -> Type -> Prop) -> ErrorMsg -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> Type -> Prop
mkProp_

-- | The unwrapped version of 'mkProp'.
mkProp_ :: String -> Type -> Prop
mkProp_ :: ErrorMsg -> Type -> Prop
mkProp_ ErrorMsg
name Type
t =
  let Char
c:ErrorMsg
cs = ErrorMsg
name
      setName :: ErrorMsg
setName = Char
's' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'e' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
't' Char -> ShowS
forall a. a -> [a] -> [a]
: Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ErrorMsg
cs
  in [Method] -> Prop
Prop [ ErrorMsg -> [Parameter] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_ ErrorMsg
name [Parameter]
np Type
t
          , ErrorMsg -> [Type] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_ ErrorMsg
setName [Type
t] Type
Internal_TVoid
          ]

-- | Creates a getter/setter binding pair for static methods:
--
-- > static T foo() const
-- > static void setFoo(T)
mkStaticProp :: String -> Type -> ClassEntity
mkStaticProp :: ErrorMsg -> Type -> ClassEntity
mkStaticProp = (Prop -> ClassEntity
CEProp (Prop -> ClassEntity) -> (Type -> Prop) -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Prop) -> Type -> ClassEntity)
-> (ErrorMsg -> Type -> Prop) -> ErrorMsg -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> Type -> Prop
mkStaticProp_

-- | The unwrapped version of 'mkStaticProp'.
mkStaticProp_ :: String -> Type -> Prop
mkStaticProp_ :: ErrorMsg -> Type -> Prop
mkStaticProp_ ErrorMsg
name Type
t =
  let Char
c:ErrorMsg
cs = ErrorMsg
name
      setName :: ErrorMsg
setName = Char
's' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'e' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
't' Char -> ShowS
forall a. a -> [a] -> [a]
: Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ErrorMsg
cs
  in [Method] -> Prop
Prop [ ErrorMsg -> [Parameter] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkStaticMethod_ ErrorMsg
name [Parameter]
np Type
t
          , ErrorMsg -> [Type] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkStaticMethod_ ErrorMsg
setName [Type
t] Type
Internal_TVoid
          ]

-- | Creates a getter/setter binding pair for boolean methods, where the getter
-- is prefixed with @is@:
--
-- > bool isFoo() const
-- > void setFoo(bool)
--
-- The result is wrapped in a 'CEProp'.  For an unwrapped value, use
-- 'mkBoolIsProp_'.
mkBoolIsProp :: String -> ClassEntity
mkBoolIsProp :: ErrorMsg -> ClassEntity
mkBoolIsProp = Prop -> ClassEntity
CEProp (Prop -> ClassEntity)
-> (ErrorMsg -> Prop) -> ErrorMsg -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> Prop
mkBoolIsProp_

-- | The unwrapped version of 'mkBoolIsProp'.
mkBoolIsProp_ :: String -> Prop
mkBoolIsProp_ :: ErrorMsg -> Prop
mkBoolIsProp_ ErrorMsg
name =
  let Char
c:ErrorMsg
cs = ErrorMsg
name
      name' :: ErrorMsg
name' = Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ErrorMsg
cs
      isName :: ErrorMsg
isName = Char
'i'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
's'Char -> ShowS
forall a. a -> [a] -> [a]
:ErrorMsg
name'
      setName :: ErrorMsg
setName = Char
's'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'e'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
't'Char -> ShowS
forall a. a -> [a] -> [a]
:ErrorMsg
name'
  in [Method] -> Prop
Prop [ ErrorMsg -> [Parameter] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_ ErrorMsg
isName [Parameter]
np Type
boolT
          , ErrorMsg -> [Type] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_ ErrorMsg
setName [Type
boolT] Type
voidT
          ]

-- | Creates a getter/setter binding pair for boolean methods, where the getter
-- is prefixed with @has@:
--
-- > bool hasFoo() const
-- > void setFoo(bool)
--
-- The result is wrapped in a 'CEProp'.  For an unwrapped value, use
-- 'mkBoolHasProp_'.
mkBoolHasProp :: String -> ClassEntity
mkBoolHasProp :: ErrorMsg -> ClassEntity
mkBoolHasProp = Prop -> ClassEntity
CEProp (Prop -> ClassEntity)
-> (ErrorMsg -> Prop) -> ErrorMsg -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> Prop
mkBoolHasProp_

-- | The unwrapped version of 'mkBoolHasProp'.
mkBoolHasProp_ :: String -> Prop
mkBoolHasProp_ :: ErrorMsg -> Prop
mkBoolHasProp_ ErrorMsg
name =
  let Char
c:ErrorMsg
cs = ErrorMsg
name
      name' :: ErrorMsg
name' = Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ErrorMsg
cs
      hasName :: ErrorMsg
hasName = Char
'h'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'a'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
's'Char -> ShowS
forall a. a -> [a] -> [a]
:ErrorMsg
name'
      setName :: ErrorMsg
setName = Char
's'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'e'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
't'Char -> ShowS
forall a. a -> [a] -> [a]
:ErrorMsg
name'
  in [Method] -> Prop
Prop [ ErrorMsg -> [Parameter] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_ ErrorMsg
hasName [Parameter]
np Type
boolT
          , ErrorMsg -> [Type] -> Type -> Method
forall name p.
(IsFnName ErrorMsg name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_ ErrorMsg
setName [Type
boolT] Type
voidT
          ]

sayCppExport :: LC.SayExportMode -> Class -> LC.Generator ()
sayCppExport :: SayExportMode -> Class -> Generator ()
sayCppExport SayExportMode
mode Class
cls = case SayExportMode
mode of
  SayExportMode
LC.SayHeader -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  SayExportMode
LC.SaySource -> do
    let clsPtr :: Type
clsPtr = Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls
        constClsPtr :: Type
constClsPtr = Type -> Type
ptrT (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
    -- TODO Is this redundant for a completely empty class?  (No ctors or methods, private dtor.)
    Reqs -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Reqs -> m ()
LC.addReqsM (Reqs -> Generator ()) -> Reqs -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Reqs
classReqs Class
cls  -- This is needed at least for the delete function.

    -- Export each of the class's constructors.
    [Ctor] -> (Ctor -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Ctor]
classCtors Class
cls) ((Ctor -> Generator ()) -> Generator ())
-> (Ctor -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Ctor
ctor ->
      ExtName
-> CppCallType
-> Maybe Type
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Bool
-> Generator ()
Function.sayCppExportFn
        (Class -> Ctor -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls Ctor
ctor)
        (Generator () -> CppCallType
Function.CallFn (Generator () -> CppCallType) -> Generator () -> CppCallType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"new" Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Identifier -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier (Class -> Identifier
classIdentifier Class
cls))
        Maybe Type
forall a. Maybe a
Nothing
        (Ctor -> [Parameter]
ctorParams Ctor
ctor)
        Type
clsPtr
        (Ctor -> ExceptionHandlers
ctorExceptionHandlers Ctor
ctor)
        Bool
True  -- Render the body.

    -- Export a delete function for the class.
    Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Class -> Bool
classDtorIsPublic Class
cls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      ErrorMsg
-> [ErrorMsg] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (Class -> ErrorMsg
cppDeleteFnName Class
cls)
                     [ErrorMsg
"self"]
                     ([Type] -> Type -> Type
fnT [Type
constClsPtr] Type
voidT) (Maybe (Generator ()) -> Generator ())
-> Maybe (Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$
        Generator () -> Maybe (Generator ())
forall a. a -> Maybe a
Just (Generator () -> Maybe (Generator ()))
-> Generator () -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"delete self;\n"

    -- Export each of the class's variables.
    [ClassVariable] -> (ClassVariable -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [ClassVariable]
classVariables Class
cls) ((ClassVariable -> Generator ()) -> Generator ())
-> (ClassVariable -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> ClassVariable -> Generator ()
sayCppExportClassVar Class
cls

    -- Export each of the class's methods.
    [Method] -> (Method -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Method]
classMethods Class
cls) ((Method -> Generator ()) -> Generator ())
-> (Method -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Method
method -> do
      let static :: Bool
static = case Method -> Staticness
methodStatic Method
method of
            Staticness
Static -> Bool
True
            Staticness
Nonstatic -> Bool
False
          thisType :: Type
thisType = case Method -> Constness
methodConst Method
method of
            Constness
Const -> Type
constClsPtr
            Constness
Nonconst -> Type
clsPtr
          nonMemberCall :: Bool
nonMemberCall = Bool
static Bool -> Bool -> Bool
|| case Method -> MethodImpl
methodImpl Method
method of
            RealMethod {} -> Bool
False
            FnMethod {} -> Bool
True
      ExtName
-> CppCallType
-> Maybe Type
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Bool
-> Generator ()
Function.sayCppExportFn
        (Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls Method
method)
        (case Method -> MethodImpl
methodImpl Method
method of
           RealMethod FnName ErrorMsg
name -> case FnName ErrorMsg
name of
             FnName ErrorMsg
cName -> Generator () -> CppCallType
Function.CallFn (Generator () -> CppCallType) -> Generator () -> CppCallType
forall a b. (a -> b) -> a -> b
$ do
               Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
static (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
                 Identifier -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier (Class -> Identifier
classIdentifier Class
cls)
                 ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"::"
               ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
cName
             FnOp Operator
op -> Operator -> CppCallType
Function.CallOp Operator
op
           FnMethod FnName Identifier
name -> case FnName Identifier
name of
             FnName Identifier
cName -> Generator () -> CppCallType
Function.CallFn (Generator () -> CppCallType) -> Generator () -> CppCallType
forall a b. (a -> b) -> a -> b
$ Identifier -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Identifier -> m ()
LC.sayIdentifier Identifier
cName
             FnOp Operator
op -> Operator -> CppCallType
Function.CallOp Operator
op)
        (if Bool
nonMemberCall then Maybe Type
forall a. Maybe a
Nothing else Type -> Maybe Type
forall a. a -> Maybe a
Just Type
thisType)
        (Method -> [Parameter]
methodParams Method
method)
        (Method -> Type
methodReturn Method
method)
        (Method -> ExceptionHandlers
methodExceptionHandlers Method
method)
        Bool
True  -- Render the body.

    -- Export upcast functions for the class to its direct superclasses.
    [Class] -> (Class -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Class]
classSuperclasses Class
cls) ((Class -> Generator ()) -> Generator ())
-> (Class -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Class -> Generator ()
genUpcastFns Class
cls
    -- Export downcast functions from the class's direct and indirect
    -- superclasses to it.
    Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Class -> Bool
classIsSubclassOfMonomorphic Class
cls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      [Class] -> (Class -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Class]
classSuperclasses Class
cls) ((Class -> Generator ()) -> Generator ())
-> (Class -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Class -> Generator ()
genDowncastFns Class
cls

  where genUpcastFns :: Class -> Class -> LC.Generator ()
        genUpcastFns :: Class -> Class -> Generator ()
genUpcastFns Class
cls' Class
ancestorCls = do
          ErrorMsg
-> [ErrorMsg] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (Class -> Class -> ErrorMsg
cppCastFnName Class
cls' Class
ancestorCls)
                         [ErrorMsg
"self"]
                         ([Type] -> Type -> Type
fnT [Type -> Type
ptrT (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'] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT (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
ancestorCls)
                         (Generator () -> Maybe (Generator ())
forall a. a -> Maybe a
Just (Generator () -> Maybe (Generator ()))
-> Generator () -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return self;\n")
          [Class] -> (Class -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Class]
classSuperclasses Class
ancestorCls) ((Class -> Generator ()) -> Generator ())
-> (Class -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Class -> Generator ()
genUpcastFns Class
cls'

        genDowncastFns :: Class -> Class -> LC.Generator ()
        genDowncastFns :: Class -> Class -> Generator ()
genDowncastFns Class
cls' Class
ancestorCls = Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Class -> Bool
classIsMonomorphicSuperclass Class
ancestorCls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
          let clsPtr :: Type
clsPtr = Type -> Type
ptrT (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'
              ancestorPtr :: Type
ancestorPtr = Type -> Type
ptrT (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
ancestorCls
          ErrorMsg
-> [ErrorMsg] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (Class -> Class -> ErrorMsg
cppCastFnName Class
ancestorCls Class
cls')
                         [ErrorMsg
"self"]
                         ([Type] -> Type -> Type
fnT [Type
ancestorPtr] Type
clsPtr) (Maybe (Generator ()) -> Generator ())
-> Maybe (Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ Generator () -> Maybe (Generator ())
forall a. a -> Maybe a
Just (Generator () -> Maybe (Generator ()))
-> Generator () -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ do
            ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return dynamic_cast<"
            Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [ErrorMsg] -> Type -> m ()
LC.sayType Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
clsPtr
            ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
">(self);\n"
          [Class] -> (Class -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Class]
classSuperclasses Class
ancestorCls) ((Class -> Generator ()) -> Generator ())
-> (Class -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> Class -> Generator ()
genDowncastFns Class
cls'

sayCppExportClassVar :: Class -> ClassVariable -> LC.Generator ()
sayCppExportClassVar :: Class -> ClassVariable -> Generator ()
sayCppExportClassVar Class
cls ClassVariable
v =
  Type
-> Maybe (Type, Type)
-> Bool
-> ExtName
-> ExtName
-> Generator ()
-> Generator ()
sayCppExportVar (ClassVariable -> Type
classVarType ClassVariable
v)
                  (case ClassVariable -> Staticness
classVarStatic ClassVariable
v of
                     Staticness
Nonstatic -> (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type -> Type
ptrT (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, Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls)
                     Staticness
Static -> Maybe (Type, Type)
forall a. Maybe a
Nothing)
                  (ClassVariable -> Bool
classVarGettable ClassVariable
v)
                  (Class -> ClassVariable -> ExtName
classVarGetterExtName Class
cls ClassVariable
v)
                  (Class -> ClassVariable -> ExtName
classVarSetterExtName Class
cls ClassVariable
v)
                  (case ClassVariable -> Staticness
classVarStatic ClassVariable
v of
                     Staticness
Nonstatic -> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ ClassVariable -> ErrorMsg
classVarCName ClassVariable
v
                     Staticness
Static -> 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
classIdentifier Class
cls
                                  [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"::", ClassVariable -> ErrorMsg
classVarCName ClassVariable
v])

makeClassCppName :: String -> Class -> String
makeClassCppName :: ErrorMsg -> Class -> ErrorMsg
makeClassCppName ErrorMsg
prefix Class
cls = [ErrorMsg] -> ErrorMsg
LC.makeCppName [ErrorMsg
prefix, ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
cls]

-- | \"gendel\" is the prefix used for wrappers for @delete@ calls.
cppDeleteFnPrefix :: String
cppDeleteFnPrefix :: ErrorMsg
cppDeleteFnPrefix = ErrorMsg
"gendel"

-- | Returns the C++ binding function name of the wrapper for the delete method
-- for a class.
cppDeleteFnName :: Class -> String
cppDeleteFnName :: Class -> ErrorMsg
cppDeleteFnName = ErrorMsg -> Class -> ErrorMsg
makeClassCppName ErrorMsg
cppDeleteFnPrefix

-- | @cppCastFnName fromCls toCls@ returns the name of the generated C++
-- function that casts a pointer from @fromCls@ to @toCls@.
cppCastFnName :: Class -> Class -> String
cppCastFnName :: Class -> Class -> ErrorMsg
cppCastFnName Class
from Class
to =
  [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ErrorMsg
"gencast__"
         , ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
from
         , ErrorMsg
"__"
         , ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
to
         ]

sayHsExport :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExport :: SayExportMode -> Class -> Generator ()
sayHsExport SayExportMode
mode Class
cls = ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext (ErrorMsg
"generating class " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Class -> ExtName
classExtName Class
cls)) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  case SayExportMode
mode of
    SayExportMode
LH.SayExportForeignImports -> do
      SayExportMode -> Class -> Generator ()
sayHsExportClassVars SayExportMode
mode Class
cls
      SayExportMode -> Class -> Generator ()
sayHsExportClassCtors SayExportMode
mode Class
cls

      [Method] -> (Method -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Method]
classMethods Class
cls) ((Method -> Generator ()) -> Generator ())
-> (Method -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Method
method ->
        (SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
Function.sayHsExportFn SayExportMode
mode (ExtName
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> ExtName)
-> Method
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls (Method
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> ExtName)
-> Method
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls (Method
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> Purity)
-> Method
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
         Method -> Purity
methodPurity (Method
 -> [Parameter] -> Type -> ExceptionHandlers -> Generator ())
-> (Method -> [Parameter])
-> Method
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Parameter] -> Method -> [Parameter]
forall a. a -> Method -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Class -> Method -> [Parameter]
getMethodEffectiveParams Class
cls Method
method) (Method -> Type -> ExceptionHandlers -> Generator ())
-> (Method -> Type) -> Method -> ExceptionHandlers -> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
         Method -> Type
methodReturn (Method -> ExceptionHandlers -> Generator ())
-> (Method -> ExceptionHandlers) -> Method -> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Method -> ExceptionHandlers
methodExceptionHandlers)
        Method
method

    SayExportMode
LH.SayExportDecls -> do
      Bool -> Class -> Constness -> Generator ()
sayHsExportClassClass Bool
True Class
cls Constness
Const
      Bool -> Class -> Constness -> Generator ()
sayHsExportClassClass Bool
True Class
cls Constness
Nonconst

      Class -> Generator ()
sayHsExportClassStaticMethods Class
cls

      -- Create a newtype for referencing foreign objects with pointers.  The
      -- newtype is not used with encodings of value objects.
      Bool -> Class -> Constness -> Generator ()
sayHsExportClassDataType Bool
True Class
cls Constness
Const
      Bool -> Class -> Constness -> Generator ()
sayHsExportClassDataType Bool
True Class
cls Constness
Nonconst

      Bool -> Class -> Generator ()
sayHsExportClassExceptionSupport Bool
True Class
cls

      SayExportMode -> Class -> Generator ()
sayHsExportClassVars SayExportMode
mode Class
cls
      SayExportMode -> Class -> Generator ()
sayHsExportClassCtors SayExportMode
mode Class
cls

    SayExportMode
LH.SayExportBoot -> do
      Bool -> Class -> Constness -> Generator ()
sayHsExportClassClass Bool
False Class
cls Constness
Const
      Bool -> Class -> Constness -> Generator ()
sayHsExportClassClass Bool
False Class
cls Constness
Nonconst

      Bool -> Class -> Constness -> Generator ()
sayHsExportClassDataType Bool
False Class
cls Constness
Const
      Bool -> Class -> Constness -> Generator ()
sayHsExportClassDataType Bool
False Class
cls Constness
Nonconst

      Bool -> Class -> Generator ()
sayHsExportClassExceptionSupport Bool
False Class
cls

      SayExportMode -> Class -> Generator ()
sayHsExportClassVars SayExportMode
mode Class
cls

  SayExportMode -> Class -> Generator ()
sayHsExportClassCastPrimitives SayExportMode
mode Class
cls
  SayExportMode -> Class -> Generator ()
sayHsExportClassSpecialFns SayExportMode
mode Class
cls

sayHsExportClassClass :: Bool -> Class -> Constness -> LH.Generator ()
sayHsExportClassClass :: Bool -> Class -> Constness -> Generator ()
sayHsExportClassClass Bool
doDecls Class
cls Constness
cst = ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating Haskell typeclass" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  ErrorMsg
hsTypeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
cst Class
cls
  ErrorMsg
hsValueClassName <- Class -> Generator ErrorMsg
toHsValueClassName Class
cls
  ErrorMsg
hsWithValuePtrName <- Class -> Generator ErrorMsg
toHsWithValuePtrName Class
cls
  ErrorMsg
hsPtrClassName <- Constness -> Class -> Generator ErrorMsg
toHsPtrClassName Constness
cst Class
cls
  ErrorMsg
hsCastMethodName <- Constness -> Class -> Generator ErrorMsg
toHsCastMethodName Constness
cst Class
cls
  let supers :: [Class]
supers = Class -> [Class]
classSuperclasses Class
cls

  [ErrorMsg]
hsSupers <-
    (\[ErrorMsg]
x -> if [ErrorMsg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMsg]
x
           then do HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
                   [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg
"HoppyFHR.CppPtr"]
           else [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg]
x) ([ErrorMsg]
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg])
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    case Constness
cst of
      Constness
Const -> (Class -> Generator ErrorMsg)
-> [Class]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Constness -> Class -> Generator ErrorMsg
toHsPtrClassName Constness
Const) [Class]
supers
      Constness
Nonconst ->
        (:) (ErrorMsg -> [ErrorMsg] -> [ErrorMsg])
-> Generator ErrorMsg
-> ReaderT
     Env (WriterT Output (Except ErrorMsg)) ([ErrorMsg] -> [ErrorMsg])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Constness -> Class -> Generator ErrorMsg
toHsPtrClassName Constness
Const Class
cls ReaderT
  Env (WriterT Output (Except ErrorMsg)) ([ErrorMsg] -> [ErrorMsg])
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a b.
ReaderT Env (WriterT Output (Except ErrorMsg)) (a -> b)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) a
-> ReaderT Env (WriterT Output (Except ErrorMsg)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Class -> Generator ErrorMsg)
-> [Class]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Constness -> Class -> Generator ErrorMsg
toHsPtrClassName Constness
Nonconst) [Class]
supers

  -- Print the value class definition.  There is only one of these, and it is
  -- spiritually closer to the const version of the pointers for this class, so
  -- we emit for the const case only.
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Constness
cst Constness -> Constness -> Bool
forall a. Eq a => a -> a -> Bool
== Constness
Const) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
    ErrorMsg -> Generator ()
LH.addExport' ErrorMsg
hsValueClassName
    Generator ()
LH.ln
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"class ", ErrorMsg
hsValueClassName, ErrorMsg
" a where"]
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsWithValuePtrName, ErrorMsg
" :: a -> (", ErrorMsg
hsTypeName, ErrorMsg
" -> HoppyP.IO b) -> HoppyP.IO b"]

    -- Generate instances for all pointer subtypes.
    Generator ()
LH.ln
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance {-# OVERLAPPABLE #-} ", ErrorMsg
hsPtrClassName, ErrorMsg
" a => ", ErrorMsg
hsValueClassName, ErrorMsg
" a",
               if Bool
doDecls then ErrorMsg
" where" else ErrorMsg
""]
    Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
      HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> [ErrorMsg] -> HsImportSet
hsImports ErrorMsg
"Prelude" [ErrorMsg
"($)", ErrorMsg
"(.)"],
                               HsImportSet
hsImportForPrelude]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsWithValuePtrName, ErrorMsg
" = HoppyP.flip ($) . ", ErrorMsg
hsCastMethodName]

    -- When the class is encodable to a native Haskell type, also print an
    -- instance for it.
    let conv :: ClassHaskellConversion
conv = Class -> ClassHaskellConversion
LH.getClassHaskellConversion Class
cls
    case (ClassHaskellConversion -> Maybe (Generator HsType)
classHaskellConversionType ClassHaskellConversion
conv,
          ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionToCppFn ClassHaskellConversion
conv) of
      (Just Generator HsType
hsTypeGen, Just Generator ()
_) -> do
        HsType
hsType <- Generator HsType
hsTypeGen
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance {-# OVERLAPPING #-} ", ErrorMsg
hsValueClassName,
                   ErrorMsg
" (", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
hsType, ErrorMsg
")", if Bool
doDecls then ErrorMsg
" where" else ErrorMsg
""]
        Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
          HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
          Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsWithValuePtrName, ErrorMsg
" = HoppyFHR.withCppObj"]
      (Maybe (Generator HsType), Maybe (Generator ()))
_ -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Print the pointer class definition.
  ErrorMsg -> Generator ()
LH.addExport' ErrorMsg
hsPtrClassName
  Generator ()
LH.ln
  [ErrorMsg] -> Generator ()
LH.saysLn ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$
    ErrorMsg
"class (" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
    ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
intersperse ErrorMsg
", " (ShowS -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" this") [ErrorMsg]
hsSupers) [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++
    [ErrorMsg
") => ", ErrorMsg
hsPtrClassName, ErrorMsg
" this where"]
  Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsCastMethodName, ErrorMsg
" :: this -> ", ErrorMsg
hsTypeName]

  -- Print the non-static methods.
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    let methods :: [Method]
methods = (Method -> Bool) -> [Method] -> [Method]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Constness
cst Constness -> Constness -> Bool
forall a. Eq a => a -> a -> Bool
==) (Constness -> Bool) -> (Method -> Constness) -> Method -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Constness
methodConst) ([Method] -> [Method]) -> [Method] -> [Method]
forall a b. (a -> b) -> a -> b
$ Class -> [Method]
classMethods Class
cls
    [Method] -> (Method -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Method]
methods ((Method -> Generator ()) -> Generator ())
-> (Method -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Method
method ->
      Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Method -> Staticness
methodStatic Method
method Staticness -> Staticness -> Bool
forall a. Eq a => a -> a -> Bool
== Staticness
Nonstatic) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      (SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
Function.sayHsExportFn SayExportMode
LH.SayExportDecls (ExtName
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> ExtName)
-> Method
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
       Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls (Method
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> ExtName)
-> Method
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls (Method
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> Purity)
-> Method
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
       Method -> Purity
methodPurity (Method
 -> [Parameter] -> Type -> ExceptionHandlers -> Generator ())
-> (Method -> [Parameter])
-> Method
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Parameter] -> Method -> [Parameter]
forall a. a -> Method -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Class -> Method -> [Parameter]
getMethodEffectiveParams Class
cls Method
method) (Method -> Type -> ExceptionHandlers -> Generator ())
-> (Method -> Type) -> Method -> ExceptionHandlers -> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
       Method -> Type
methodReturn (Method -> ExceptionHandlers -> Generator ())
-> (Method -> ExceptionHandlers) -> Method -> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Method -> ExceptionHandlers
methodExceptionHandlers) Method
method

sayHsExportClassStaticMethods :: Class -> LH.Generator ()
sayHsExportClassStaticMethods :: Class -> Generator ()
sayHsExportClassStaticMethods Class
cls =
  [Method] -> (Method -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Method]
classMethods Class
cls) ((Method -> Generator ()) -> Generator ())
-> (Method -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Method
method ->
    Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Method -> Staticness
methodStatic Method
method Staticness -> Staticness -> Bool
forall a. Eq a => a -> a -> Bool
== Staticness
Static) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    (SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
Function.sayHsExportFn SayExportMode
LH.SayExportDecls (ExtName
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> ExtName)
-> Method
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
     Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls (Method
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> ExtName)
-> Method
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Class -> Method -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls (Method
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Method -> Purity)
-> Method
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
     Method -> Purity
methodPurity (Method
 -> [Parameter] -> Type -> ExceptionHandlers -> Generator ())
-> (Method -> [Parameter])
-> Method
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Method -> [Parameter]
methodParams (Method -> Type -> ExceptionHandlers -> Generator ())
-> (Method -> Type) -> Method -> ExceptionHandlers -> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Method -> Type
methodReturn (Method -> ExceptionHandlers -> Generator ())
-> (Method -> ExceptionHandlers) -> Method -> Generator ()
forall a b. (Method -> a -> b) -> (Method -> a) -> Method -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Method -> ExceptionHandlers
methodExceptionHandlers) Method
method

sayHsExportClassDataType :: Bool -> Class -> Constness -> LH.Generator ()
sayHsExportClassDataType :: Bool -> Class -> Constness -> Generator ()
sayHsExportClassDataType Bool
doDecls Class
cls Constness
cst = ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating Haskell data types" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  ErrorMsg
hsTypeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
cst Class
cls
  ErrorMsg
hsCtor <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged Constness
cst Class
cls
  ErrorMsg
hsCtorGc <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Managed Constness
cst Class
cls
  ErrorMsg
constCastFnName <- Constness -> Class -> Generator ErrorMsg
toHsConstCastFnName Constness
cst Class
cls

  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
hsImportForForeign, HsImportSet
hsImportForPrelude, HsImportSet
hsImportForRuntime]
  -- Unfortunately, we must export the data constructor, so that GHC can marshal
  -- it in foreign calls in other modules.
  ErrorMsg -> Generator ()
LH.addExport' ErrorMsg
hsTypeName
  Generator ()
LH.ln
  [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"data ", ErrorMsg
hsTypeName, ErrorMsg
" ="]
  Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"  ", ErrorMsg
hsCtor, ErrorMsg
" (HoppyF.Ptr ", ErrorMsg
hsTypeName, ErrorMsg
")"]
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"| ", ErrorMsg
hsCtorGc, ErrorMsg
" (HoppyF.ForeignPtr ()) (HoppyF.Ptr ", ErrorMsg
hsTypeName, ErrorMsg
")"]
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(==)"
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"deriving (HoppyP.Show)"
    Generator ()
LH.ln
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyP.Eq ", ErrorMsg
hsTypeName, ErrorMsg
" where"]
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"x == y = HoppyFHR.toPtr x == HoppyFHR.toPtr y"]
    Generator ()
LH.ln
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyP.Ord ", ErrorMsg
hsTypeName, ErrorMsg
" where"]
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"compare x y = HoppyP.compare (HoppyFHR.toPtr x) (HoppyFHR.toPtr y)"]

  -- Generate const_cast functions:
  --   castFooToConst :: Foo -> FooConst
  --   castFooToNonconst :: FooConst -> Foo
  ErrorMsg
hsTypeNameOppConst <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName (Constness -> Constness
constNegate Constness
cst) Class
cls
  Generator ()
LH.ln
  ErrorMsg -> Generator ()
LH.addExport ErrorMsg
constCastFnName
  [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
constCastFnName, ErrorMsg
" :: ", ErrorMsg
hsTypeNameOppConst, ErrorMsg
" -> ", ErrorMsg
hsTypeName]
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)"
    ErrorMsg
hsCtorOppConst <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged (Constness -> Constness
constNegate Constness
cst) Class
cls
    ErrorMsg
hsCtorGcOppConst <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Managed (Constness -> Constness
constNegate Constness
cst) Class
cls
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
constCastFnName, ErrorMsg
" (", ErrorMsg
hsCtorOppConst,
               ErrorMsg
" ptr') = ", ErrorMsg
hsCtor, ErrorMsg
" $ HoppyF.castPtr ptr'"]
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
constCastFnName, ErrorMsg
" (", ErrorMsg
hsCtorGcOppConst,
               ErrorMsg
" fptr' ptr') = ", ErrorMsg
hsCtorGc, ErrorMsg
" fptr' $ HoppyF.castPtr ptr'"]

  -- Generate an instance of CppPtr.
  Generator ()
LH.ln
  if Bool
doDecls
    then do HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)"
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.CppPtr ", ErrorMsg
hsTypeName, ErrorMsg
" where"]
            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"nullptr = ", ErrorMsg
hsCtor, ErrorMsg
" HoppyF.nullPtr"]
              Generator ()
LH.ln
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"withCppPtr (", ErrorMsg
hsCtor, ErrorMsg
" ptr') f' = f' ptr'"]
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"withCppPtr (", ErrorMsg
hsCtorGc,
                         ErrorMsg
" fptr' ptr') f' = HoppyF.withForeignPtr fptr' $ \\_ -> f' ptr'"]
              Generator ()
LH.ln
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"toPtr (", ErrorMsg
hsCtor, ErrorMsg
" ptr') = ptr'"]
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"toPtr (", ErrorMsg
hsCtorGc, ErrorMsg
" _ ptr') = ptr'"]
              Generator ()
LH.ln
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"touchCppPtr (", ErrorMsg
hsCtor, ErrorMsg
" _) = HoppyP.return ()"]
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"touchCppPtr (", ErrorMsg
hsCtorGc, ErrorMsg
" fptr' _) = HoppyF.touchForeignPtr fptr'"]

            Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Class -> Bool
classDtorIsPublic Class
cls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
              HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(==)"
              Generator ()
LH.ln
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Deletable ", ErrorMsg
hsTypeName, ErrorMsg
" where"]
              Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
                -- Note, similar "delete" and "toGc" functions are generated for exception
                -- classes' ExceptionClassInfo structures.
                case Constness
cst of
                  Constness
Const ->
                    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"delete (", ErrorMsg
hsCtor, ErrorMsg
" ptr') = ", Class -> ErrorMsg
toHsClassDeleteFnName' Class
cls, ErrorMsg
" ptr'"]
                  Constness
Nonconst -> do
                    ErrorMsg
constTypeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Const Class
cls
                    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"delete (",ErrorMsg
hsCtor, ErrorMsg
" ptr') = ", Class -> ErrorMsg
toHsClassDeleteFnName' Class
cls,
                               ErrorMsg
" $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ", ErrorMsg
constTypeName, ErrorMsg
")"]
                [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"delete (", ErrorMsg
hsCtorGc,
                           ErrorMsg
" _ _) = HoppyP.fail $ HoppyP.concat ",
                           ErrorMsg
"[\"Deletable.delete: Asked to delete a GC-managed \", ",
                           ShowS
forall a. Show a => a -> ErrorMsg
show ErrorMsg
hsTypeName, ErrorMsg
", \" object.\"]"]
                Generator ()
LH.ln
                [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"toGc this'@(", ErrorMsg
hsCtor, ErrorMsg
" ptr') = ",
                           -- No sense in creating a ForeignPtr for a null pointer.
                           ErrorMsg
"if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ",
                           ErrorMsg
"(HoppyP.flip ", ErrorMsg
hsCtorGc, ErrorMsg
" ptr') $ ",
                           ErrorMsg
"HoppyF.newForeignPtr ",
                           -- The foreign delete function takes a const pointer; we cast it to
                           -- take a Ptr () to match up with the ForeignPtr () we're creating,
                           -- assuming that data pointers have the same representation.
                           ErrorMsg
"(HoppyF.castFunPtr ", Class -> ErrorMsg
toHsClassDeleteFnPtrName' Class
cls,
                           ErrorMsg
" :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",
                           ErrorMsg
"(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"]
                [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"toGc this'@(", ErrorMsg
hsCtorGc, ErrorMsg
" {}) = HoppyP.return this'"]

            Maybe Ctor -> (Ctor -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> Maybe Ctor
classFindCopyCtor Class
cls) ((Ctor -> Generator ()) -> Generator ())
-> (Ctor -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Ctor
copyCtor -> do
              ErrorMsg
copyCtorName <- Class -> Ctor -> Generator ErrorMsg
toHsCtorName Class
cls Ctor
copyCtor
              Generator ()
LH.ln
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Copyable ", ErrorMsg
hsTypeName, ErrorMsg
" ",
                         case Constness
cst of
                           Constness
Nonconst -> ErrorMsg
hsTypeName
                           Constness
Const -> ErrorMsg
hsTypeNameOppConst,
                         ErrorMsg
" where copy = ", ErrorMsg
copyCtorName]

    else do [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.CppPtr ", ErrorMsg
hsTypeName]

            Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Class -> Bool
classDtorIsPublic Class
cls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Deletable ", ErrorMsg
hsTypeName]

            Maybe Ctor -> (Ctor -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> Maybe Ctor
classFindCopyCtor Class
cls) ((Ctor -> Generator ()) -> Generator ())
-> (Ctor -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Ctor
_ ->
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Copyable ", ErrorMsg
hsTypeName, ErrorMsg
" ",
                         case Constness
cst of
                           Constness
Nonconst -> ErrorMsg
hsTypeName
                           Constness
Const -> ErrorMsg
hsTypeNameOppConst]

  -- Generate instances for all superclasses' typeclasses.
  ErrorMsg -> [Class] -> Class -> Generator ()
genInstances ErrorMsg
hsTypeName [] Class
cls

  where genInstances :: String -> [Class] -> Class -> LH.Generator ()
        genInstances :: ErrorMsg -> [Class] -> Class -> Generator ()
genInstances ErrorMsg
hsTypeName [Class]
path Class
ancestorCls = do
          -- In this example Bar inherits from Foo.  We are generating instances
          -- either for BarConst or Bar, depending on 'cst'.
          --
          -- BarConst's instances:
          --   instance FooConstPtr BarConst where
          --     toFooConst (BarConst ptr') = FooConst $ castBarToFoo ptr'
          --     toFooConst (BarConstGc fptr' ptr') = FooConstGc fptr' $ castBarToFoo ptr'
          --
          --   instance BarConstPtr BarConst where
          --     toFooConst = id
          --
          -- Bar's instances:
          --   instance FooConstPtr Bar
          --     toFooConst (Bar ptr') =
          --       FooConst $ castBarToFoo $ castBarToConst ptr'
          --     toFooConst (BarGc fptr' ptr') =
          --       FooConstGc fptr' $ castBarToFoo $ castBarToConst ptr'
          --
          --   instance FooPtr Bar
          --     toFoo (Bar ptr') =
          --       Foo $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr'
          --     toFoo (BarGc fptr' ptr') =
          --       FooGc fptr' $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr'
          --
          --   instance BarConstPtr Bar
          --     toBarConst (Bar ptr') = Bar $ castBarToConst ptr'
          --     toBarConst (BarGc fptr' ptr') = BarGc fptr' $ castBarToConst ptr'
          --
          --   instance BarPtr Bar
          --     toBar = id
          --
          -- In all cases, we unwrap the pointer, maybe add const, maybe do an
          -- upcast, maybe remove const, then rewrap the pointer.  The identity
          -- cases are where we just unwrap and wrap again.

          [Constness] -> (Constness -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (case Constness
cst of
                   Constness
Const -> [Constness
Const]
                   Constness
Nonconst -> [Constness
Const, Constness
Nonconst]) ((Constness -> Generator ()) -> Generator ())
-> (Constness -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Constness
ancestorCst -> do
            Generator ()
LH.ln
            ErrorMsg
ancestorPtrClassName <- Constness -> Class -> Generator ErrorMsg
toHsPtrClassName Constness
ancestorCst Class
ancestorCls
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance ", ErrorMsg
ancestorPtrClassName, ErrorMsg
" ", ErrorMsg
hsTypeName,
                       if Bool
doDecls then ErrorMsg
" where" else ErrorMsg
""]
            Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
              -- Unqualified, for Haskell instance methods.
              let castMethodName :: ErrorMsg
castMethodName = Constness -> Class -> ErrorMsg
toHsCastMethodName' Constness
ancestorCst Class
ancestorCls
              if [Class] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Class]
path Bool -> Bool -> Bool
&& Constness
cst Constness -> Constness -> Bool
forall a. Eq a => a -> a -> Bool
== Constness
ancestorCst
                then do HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForPrelude
                        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
castMethodName, ErrorMsg
" = HoppyP.id"]
                else do let addConst :: Bool
addConst = Constness
cst Constness -> Constness -> Bool
forall a. Eq a => a -> a -> Bool
== Constness
Nonconst
                            removeConst :: Bool
removeConst = Constness
ancestorCst Constness -> Constness -> Bool
forall a. Eq a => a -> a -> Bool
== Constness
Nonconst
                        Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
addConst Bool -> Bool -> Bool
|| Bool
removeConst) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
                          HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForForeign
                        [Managed] -> (Managed -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Managed
forall a. Bounded a => a
minBound..] :: [LH.Managed]) ((Managed -> Generator ()) -> Generator ())
-> (Managed -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Managed
managed -> do
                          [ErrorMsg]
ancestorCtor <- case Managed
managed of
                            Managed
LH.Unmanaged -> (\ErrorMsg
x -> [ErrorMsg
x]) (ErrorMsg -> [ErrorMsg])
-> Generator ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                            Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged Constness
ancestorCst Class
ancestorCls
                            Managed
LH.Managed -> (\ErrorMsg
x -> [ErrorMsg
x, ErrorMsg
" fptr'"]) (ErrorMsg -> [ErrorMsg])
-> Generator ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                          Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Managed Constness
ancestorCst Class
ancestorCls
                          [ErrorMsg]
ptrPattern <- case Managed
managed of
                            Managed
LH.Unmanaged -> (\ErrorMsg
x -> [ErrorMsg
x, ErrorMsg
" ptr'"]) (ErrorMsg -> [ErrorMsg])
-> Generator ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                            Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged Constness
cst Class
cls
                            Managed
LH.Managed -> (\ErrorMsg
x -> [ErrorMsg
x, ErrorMsg
" fptr' ptr'"]) (ErrorMsg -> [ErrorMsg])
-> Generator ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                          Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Managed Constness
cst Class
cls
                          [ErrorMsg] -> Generator ()
LH.saysLn ([ErrorMsg] -> Generator ())
-> ([[ErrorMsg]] -> [ErrorMsg]) -> [[ErrorMsg]] -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ErrorMsg]] -> [ErrorMsg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ErrorMsg]] -> Generator ())
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [[ErrorMsg]]
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [[ErrorMsg]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
                            [ [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ErrorMsg]
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg])
-> [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a b. (a -> b) -> a -> b
$
                              [ErrorMsg
castMethodName, ErrorMsg
" ("] [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
ptrPattern [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg
") = "] [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
ancestorCtor
                            , if Bool
removeConst
                              then do ErrorMsg
ancestorConstType <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Const Class
ancestorCls
                                      ErrorMsg
ancestorNonconstType <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Nonconst Class
ancestorCls
                                      [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg
" $ (HoppyF.castPtr :: HoppyF.Ptr ",
                                              ErrorMsg
ancestorConstType, ErrorMsg
" -> HoppyF.Ptr ",
                                              ErrorMsg
ancestorNonconstType, ErrorMsg
")"]
                              else [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                            , if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Class] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Class]
path
                              then do HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)"
                                      ErrorMsg
castPrimitiveName <- Class -> Class -> Class -> Generator ErrorMsg
toHsCastPrimitiveName Class
cls Class
cls Class
ancestorCls
                                      [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg
" $ ", ErrorMsg
castPrimitiveName]
                              else [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                            , if Bool
addConst
                              then do HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)"
                                      ErrorMsg
nonconstTypeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Nonconst Class
cls
                                      ErrorMsg
constTypeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Const Class
cls
                                      [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg
" $ (HoppyF.castPtr :: HoppyF.Ptr ",
                                              ErrorMsg
nonconstTypeName, ErrorMsg
" -> HoppyF.Ptr ",
                                              ErrorMsg
constTypeName, ErrorMsg
")"]
                              else [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                            , [ErrorMsg]
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ErrorMsg
" ptr'"]
                            ]

          [Class] -> (Class -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Class]
classSuperclasses Class
ancestorCls) ((Class -> Generator ()) -> Generator ())
-> (Class -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$
            ErrorMsg -> [Class] -> Class -> Generator ()
genInstances ErrorMsg
hsTypeName ([Class] -> Class -> Generator ())
-> [Class] -> Class -> Generator ()
forall a b. (a -> b) -> a -> b
$
            Class
ancestorCls Class -> [Class] -> [Class]
forall a. a -> [a] -> [a]
: [Class]
path

sayHsExportClassVars :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassVars :: SayExportMode -> Class -> Generator ()
sayHsExportClassVars SayExportMode
mode Class
cls =
  [ClassVariable] -> (ClassVariable -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [ClassVariable]
classVariables Class
cls) ((ClassVariable -> Generator ()) -> Generator ())
-> (ClassVariable -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ SayExportMode -> Class -> ClassVariable -> Generator ()
sayHsExportClassVar SayExportMode
mode Class
cls

sayHsExportClassVar :: LH.SayExportMode -> Class -> ClassVariable -> LH.Generator ()
sayHsExportClassVar :: SayExportMode -> Class -> ClassVariable -> Generator ()
sayHsExportClassVar SayExportMode
mode Class
cls ClassVariable
v =
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext (ErrorMsg
"generating variable " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (ClassVariable -> ExtName
classVarExtName ClassVariable
v)) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
  SayExportMode
-> Type
-> Maybe Class
-> Bool
-> ExtName
-> ExtName
-> ExtName
-> ExtName
-> Generator ()
sayHsExportVar SayExportMode
mode
                 (ClassVariable -> Type
classVarType ClassVariable
v)
                 (case ClassVariable -> Staticness
classVarStatic ClassVariable
v of
                    Staticness
Nonstatic -> Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
                    Staticness
Static -> Maybe Class
forall a. Maybe a
Nothing)
                 (ClassVariable -> Bool
classVarGettable ClassVariable
v)
                 (Class -> ClassVariable -> ExtName
classVarGetterExtName Class
cls ClassVariable
v)
                 (Class -> ClassVariable -> ExtName
classVarGetterForeignName Class
cls ClassVariable
v)
                 (Class -> ClassVariable -> ExtName
classVarSetterExtName Class
cls ClassVariable
v)
                 (Class -> ClassVariable -> ExtName
classVarSetterForeignName Class
cls ClassVariable
v)

sayHsExportClassCtors :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassCtors :: SayExportMode -> Class -> Generator ()
sayHsExportClassCtors SayExportMode
mode Class
cls =
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating constructors" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
  [Ctor] -> (Ctor -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Ctor]
classCtors Class
cls) ((Ctor -> Generator ()) -> Generator ())
-> (Ctor -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Ctor
ctor ->
  (SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
Function.sayHsExportFn SayExportMode
mode (ExtName
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Ctor -> ExtName)
-> Ctor
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
   Class -> Ctor -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls (Ctor
 -> ExtName
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Ctor -> ExtName)
-> Ctor
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Ctor -> a -> b) -> (Ctor -> a) -> Ctor -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Class -> Ctor -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls (Ctor
 -> Purity
 -> [Parameter]
 -> Type
 -> ExceptionHandlers
 -> Generator ())
-> (Ctor -> Purity)
-> Ctor
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Ctor -> a -> b) -> (Ctor -> a) -> Ctor -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
   Purity -> Ctor -> Purity
forall a. a -> Ctor -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Purity
Nonpure (Ctor -> [Parameter] -> Type -> ExceptionHandlers -> Generator ())
-> (Ctor -> [Parameter])
-> Ctor
-> Type
-> ExceptionHandlers
-> Generator ()
forall a b. (Ctor -> a -> b) -> (Ctor -> a) -> Ctor -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ctor -> [Parameter]
ctorParams (Ctor -> Type -> ExceptionHandlers -> Generator ())
-> (Ctor -> Type) -> Ctor -> ExceptionHandlers -> Generator ()
forall a b. (Ctor -> a -> b) -> (Ctor -> a) -> Ctor -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Ctor -> Type
forall a. a -> Ctor -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) (Ctor -> ExceptionHandlers -> Generator ())
-> (Ctor -> ExceptionHandlers) -> Ctor -> Generator ()
forall a b. (Ctor -> a -> b) -> (Ctor -> a) -> Ctor -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
   Ctor -> ExceptionHandlers
ctorExceptionHandlers) Ctor
ctor

sayHsExportClassSpecialFns :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassSpecialFns :: SayExportMode -> Class -> Generator ()
sayHsExportClassSpecialFns SayExportMode
mode Class
cls = do
  ErrorMsg
typeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Nonconst Class
cls
  ErrorMsg
typeNameConst <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Const Class
cls

  -- Say the delete function.
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating delete bindings" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    case SayExportMode
mode of
      SayExportMode
LH.SayExportForeignImports -> Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Class -> Bool
classDtorIsPublic Class
cls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ 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
hsImportForForeign, HsImportSet
hsImportForPrelude]
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"foreign import ccall \"", Class -> ErrorMsg
cppDeleteFnName Class
cls, ErrorMsg
"\" ",
                   Class -> ErrorMsg
toHsClassDeleteFnName' Class
cls, ErrorMsg
" :: HoppyF.Ptr ",
                   ErrorMsg
typeNameConst, ErrorMsg
" -> HoppyP.IO ()"]
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"foreign import ccall \"&", Class -> ErrorMsg
cppDeleteFnName Class
cls, ErrorMsg
"\" ",
                   Class -> ErrorMsg
toHsClassDeleteFnPtrName' Class
cls, ErrorMsg
" :: HoppyF.FunPtr (HoppyF.Ptr ",
                   ErrorMsg
typeNameConst, ErrorMsg
" -> HoppyP.IO ())"]
      -- The user interface to this is the generic 'delete' function, rendered
      -- elsewhere.
      SayExportMode
LH.SayExportDecls -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SayExportMode
LH.SayExportBoot -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating pointer Assignable instance" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    case SayExportMode
mode of
      SayExportMode
LH.SayExportForeignImports -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SayExportMode
LH.SayExportDecls -> do
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)",
                                 HsImportSet
hsImportForForeign,
                                 HsImportSet
hsImportForRuntime]
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Assignable (HoppyF.Ptr (HoppyF.Ptr ", ErrorMsg
typeName, ErrorMsg
")) ",
                   ErrorMsg
typeName, ErrorMsg
" where"]
        Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"assign ptr' value' = HoppyF.poke ptr' $ HoppyFHR.toPtr value'"
      SayExportMode
LH.SayExportBoot -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- If the class has an assignment operator that takes its own type, then
  -- generate an instance of Assignable.
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating Assignable instance" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    let assignmentMethods :: [Method]
assignmentMethods = ((Method -> Bool) -> [Method] -> [Method])
-> [Method] -> (Method -> Bool) -> [Method]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Method -> Bool) -> [Method] -> [Method]
forall a. (a -> Bool) -> [a] -> [a]
filter (Class -> [Method]
classMethods Class
cls) ((Method -> Bool) -> [Method]) -> (Method -> Bool) -> [Method]
forall a b. (a -> b) -> a -> b
$ \Method
m ->
          let paramTypes :: [Type]
paramTypes = (Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
parameterType ([Parameter] -> [Type]) -> [Parameter] -> [Type]
forall a b. (a -> b) -> a -> b
$ Method -> [Parameter]
methodParams Method
m
          in Method -> MethodApplicability
methodApplicability Method
m MethodApplicability -> MethodApplicability -> Bool
forall a. Eq a => a -> a -> Bool
== MethodApplicability
MNormal Bool -> Bool -> Bool
&&
             ([Type]
paramTypes [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Class -> Type
objT Class
cls] Bool -> Bool -> Bool
|| [Type]
paramTypes [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [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]) Bool -> Bool -> Bool
&&
             (case Method -> MethodImpl
methodImpl Method
m of
               RealMethod FnName ErrorMsg
name -> FnName ErrorMsg
name FnName ErrorMsg -> FnName ErrorMsg -> Bool
forall a. Eq a => a -> a -> Bool
== Operator -> FnName ErrorMsg
forall name. Operator -> FnName name
FnOp Operator
OpAssign
               FnMethod FnName Identifier
name -> FnName Identifier
name FnName Identifier -> FnName Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Operator -> FnName Identifier
forall name. Operator -> FnName name
FnOp Operator
OpAssign)
        withAssignmentMethod :: (Method -> m ()) -> m ()
withAssignmentMethod Method -> m ()
f = case [Method]
assignmentMethods of
          [] -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          [Method
m] -> Method -> m ()
f Method
m
          [Method]
_ ->
            ErrorMsg -> m ()
forall a. ErrorMsg -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> m ()) -> ErrorMsg -> m ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ErrorMsg
"Can't determine an Assignable instance to generator for ", Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
cls,
            ErrorMsg
" because it has multiple assignment operators ", [Method] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show [Method]
assignmentMethods]
    Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SayExportMode
mode SayExportMode -> SayExportMode -> Bool
forall a. Eq a => a -> a -> Bool
== SayExportMode
LH.SayExportDecls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ (Method -> Generator ()) -> Generator ()
forall {m :: * -> *}.
MonadError ErrorMsg m =>
(Method -> m ()) -> m ()
withAssignmentMethod ((Method -> Generator ()) -> Generator ())
-> (Method -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Method
m -> do
      HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(>>)", HsImportSet
hsImportForPrelude]
      ErrorMsg
valueClassName <- Class -> Generator ErrorMsg
toHsValueClassName Class
cls
      ErrorMsg
assignmentMethodName <- Class -> Method -> Generator ErrorMsg
toHsMethodName Class
cls Method
m
      Generator ()
LH.ln
      [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance ", ErrorMsg
valueClassName, ErrorMsg
" a => HoppyFHR.Assignable ", ErrorMsg
typeName, ErrorMsg
" a where"]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"assign x' y' = ", ErrorMsg
assignmentMethodName, ErrorMsg
" x' y' >> HoppyP.return ()"]

  -- A pointer to an object pointer is decodable to an object pointer by peeking
  -- at the value, so generate a Decodable instance.  You are now a two-star
  -- programmer.  There is a generic @Ptr (Ptr a)@ to @Ptr a@ instance which
  -- handles deeper levels.
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating pointer Decodable instance" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    case SayExportMode
mode of
      SayExportMode
LH.SayExportForeignImports -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      SayExportMode
LH.SayExportDecls -> do
        HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(.)",
                                 HsImportSet
hsImportForForeign,
                                 HsImportSet
hsImportForPrelude,
                                 HsImportSet
hsImportForRuntime]
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ",
                   ErrorMsg
typeName, ErrorMsg
")) ", ErrorMsg
typeName, ErrorMsg
" where"]
        Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
          ErrorMsg
ctorName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
          [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"decode = HoppyP.fmap ", ErrorMsg
ctorName, ErrorMsg
" . HoppyF.peek"]

      SayExportMode
LH.SayExportBoot -> 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
hsImportForForeign, HsImportSet
hsImportForRuntime]
        Generator ()
LH.ln
        -- TODO Encodable.
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", ErrorMsg
typeName, ErrorMsg
")) ",
                   ErrorMsg
typeName]

  -- Say Encodable and Decodable instances, if the class is encodable and
  -- decodable.
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating Encodable/Decodable instances" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    let conv :: ClassHaskellConversion
conv = Class -> ClassHaskellConversion
LH.getClassHaskellConversion Class
cls
    Maybe (Generator HsType)
-> (Generator HsType -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ClassHaskellConversion -> Maybe (Generator HsType)
classHaskellConversionType ClassHaskellConversion
conv) ((Generator HsType -> Generator ()) -> Generator ())
-> (Generator HsType -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator HsType
hsTypeGen -> do
      let hsTypeStrGen :: Generator ErrorMsg
hsTypeStrGen = Generator HsType
hsTypeGen Generator HsType
-> (HsType -> Generator ErrorMsg) -> Generator ErrorMsg
forall a b.
ReaderT Env (WriterT Output (Except ErrorMsg)) a
-> (a -> ReaderT Env (WriterT Output (Except ErrorMsg)) b)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \HsType
hsType -> ErrorMsg -> Generator ErrorMsg
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"(" ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
hsType ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
")"

      case SayExportMode
mode of
        SayExportMode
LH.SayExportForeignImports -> () -> Generator ()
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        SayExportMode
LH.SayExportDecls -> do
          -- Say the Encodable instances.
          Maybe (Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionToCppFn ClassHaskellConversion
conv) ((Generator () -> Generator ()) -> Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator ()
toCppFnGen -> do
            ErrorMsg
hsTypeStr <- Generator ErrorMsg
hsTypeStrGen
            HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [HsImportSet
hsImportForPrelude, HsImportSet
hsImportForRuntime]
            ErrorMsg
castMethodName <- Constness -> Class -> Generator ErrorMsg
toHsCastMethodName Constness
Const Class
cls

            Generator ()
LH.ln
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Encodable ", ErrorMsg
typeName, ErrorMsg
" ", ErrorMsg
hsTypeStr, ErrorMsg
" where"]
            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
              ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"encode ="
              Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent Generator ()
toCppFnGen
            Generator ()
LH.ln
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Encodable ", ErrorMsg
typeNameConst, ErrorMsg
" ", ErrorMsg
hsTypeStr, ErrorMsg
" where"]
            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"encode = HoppyP.fmap (", ErrorMsg
castMethodName,
                         ErrorMsg
") . HoppyFHR.encodeAs (HoppyP.undefined :: ", ErrorMsg
typeName, ErrorMsg
")"]

          -- Say the Decodable instances.
          Maybe (Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionFromCppFn ClassHaskellConversion
conv) ((Generator () -> Generator ()) -> Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator ()
fromCppFnGen -> do
            ErrorMsg
hsTypeStr <- Generator ErrorMsg
hsTypeStrGen
            HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
            ErrorMsg
castMethodName <- Constness -> Class -> Generator ErrorMsg
toHsCastMethodName Constness
Const Class
cls

            Generator ()
LH.ln
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Decodable ", ErrorMsg
typeName, ErrorMsg
" ", ErrorMsg
hsTypeStr, ErrorMsg
" where"]
            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
              [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"decode = HoppyFHR.decode . ", ErrorMsg
castMethodName]
            Generator ()
LH.ln
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Decodable ", ErrorMsg
typeNameConst, ErrorMsg
" ", ErrorMsg
hsTypeStr, ErrorMsg
" where"]
            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
              ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"decode ="
              Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent Generator ()
fromCppFnGen

        SayExportMode
LH.SayExportBoot -> do
          -- Say the Encodable instances.
          Maybe (Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionToCppFn ClassHaskellConversion
conv) ((Generator () -> Generator ()) -> Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator ()
_ -> do
            ErrorMsg
hsTypeStr <- Generator ErrorMsg
hsTypeStrGen
            HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
            Generator ()
LH.ln
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Encodable ", ErrorMsg
typeName, ErrorMsg
" (", ErrorMsg
hsTypeStr, ErrorMsg
")"]
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Encodable ", ErrorMsg
typeNameConst, ErrorMsg
" (", ErrorMsg
hsTypeStr, ErrorMsg
")"]

          -- Say the Decodable instances.
          Maybe (Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionFromCppFn ClassHaskellConversion
conv) ((Generator () -> Generator ()) -> Generator ())
-> (Generator () -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Generator ()
_ -> do
            ErrorMsg
hsTypeStr <- Generator ErrorMsg
hsTypeStrGen
            HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
            Generator ()
LH.ln
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Decodable ", ErrorMsg
typeName, ErrorMsg
" (", ErrorMsg
hsTypeStr, ErrorMsg
")"]
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.Decodable ", ErrorMsg
typeNameConst, ErrorMsg
" (", ErrorMsg
hsTypeStr, ErrorMsg
")"]

-- | Generates a non-const @CppException@ instance if the class is an exception
-- class.
sayHsExportClassExceptionSupport :: Bool -> Class -> LH.Generator ()
sayHsExportClassExceptionSupport :: Bool -> Class -> Generator ()
sayHsExportClassExceptionSupport Bool
doDecls Class
cls =
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Class -> Bool
classIsException Class
cls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating exception support" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  ErrorMsg
typeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Nonconst Class
cls
  ErrorMsg
typeNameConst <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Const Class
cls

  -- Generate a non-const CppException instance.
  ExceptionId
exceptionId <- Class -> Generator ExceptionId
getHsClassExceptionId Class
cls
  HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
  Generator ()
LH.ln
  [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.CppException ", ErrorMsg
typeName,
             if Bool
doDecls then ErrorMsg
" where" else ErrorMsg
""]
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    ErrorMsg
ctorName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
    ErrorMsg
ctorGcName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Managed Constness
Nonconst Class
cls
    HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> [ErrorMsg] -> HsImportSet
hsImports ErrorMsg
"Prelude" [ErrorMsg
"($)", ErrorMsg
"(.)", ErrorMsg
"(=<<)"],
                             HsImportSet
hsImportForForeign,
                             HsImportSet
hsImportForMap,
                             HsImportSet
hsImportForPrelude]
    ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"cppExceptionInfo _ ="
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
      [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"HoppyFHR.ExceptionClassInfo (HoppyFHR.ExceptionId ",
                 Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Int -> ErrorMsg) -> Int -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
exceptionId, ErrorMsg
") ", ShowS
forall a. Show a => a -> ErrorMsg
show ErrorMsg
typeName,
                 ErrorMsg
" upcasts' delete' copy' toGc'"]

      -- Note, similar "delete" and "toGc" functions are generated for the class's
      -- Deletable instance.
      [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"where delete' ptr' = ", Class -> ErrorMsg
toHsClassDeleteFnName' Class
cls,
                 ErrorMsg
" (HoppyF.castPtr ptr' :: HoppyF.Ptr ", ErrorMsg
typeNameConst, ErrorMsg
")"]

      Int -> Generator () -> Generator ()
forall a. Int -> Generator a -> Generator a
LH.indentSpaces Int
6 (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"copy' = HoppyP.fmap (HoppyF.castPtr . HoppyFHR.toPtr) . HoppyFHR.copy . ",
                   ErrorMsg
ctorName, ErrorMsg
" . HoppyF.castPtr"]

        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"toGc' ptr' = HoppyF.newForeignPtr ",
                   -- The foreign delete function takes a const pointer; we cast it to
                   -- take a Ptr () to match up with the ForeignPtr () we're creating,
                   -- assuming that data pointers have the same representation.
                   ErrorMsg
"(HoppyF.castFunPtr ", Class -> ErrorMsg
toHsClassDeleteFnPtrName' Class
cls,
                   ErrorMsg
" :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",
                   ErrorMsg
"ptr'"]

        ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"upcasts' = HoppyDM.fromList"
        Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ case Class -> [Class]
classSuperclasses Class
cls of
          [] -> ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"[]"
          [Class]
_ -> do
            let genCast :: Bool -> [Class] -> Class -> LH.Generator ()
                genCast :: Bool -> [Class] -> Class -> Generator ()
genCast Bool
first [Class]
path Class
ancestorCls =
                  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Class -> Bool
classIsException Class
ancestorCls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
                    let path' :: [Class]
path' = Class
ancestorCls Class -> [Class] -> [Class]
forall a. a -> [a] -> [a]
: [Class]
path
                    ExceptionId
ancestorId <- Class -> Generator ExceptionId
getHsClassExceptionId Class
ancestorCls
                    [ErrorMsg]
ancestorCastChain <- [(Class, Class)]
-> ((Class, Class) -> Generator ErrorMsg)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Class] -> [Class] -> [(Class, Class)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Class]
path' ([Class] -> [(Class, Class)]) -> [Class] -> [(Class, Class)]
forall a b. (a -> b) -> a -> b
$ Int -> [Class] -> [Class]
forall a. Int -> [a] -> [a]
drop Int
1 [Class]
path') (((Class, Class) -> Generator ErrorMsg)
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg])
-> ((Class, Class) -> Generator ErrorMsg)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) [ErrorMsg]
forall a b. (a -> b) -> a -> b
$ \(Class
to, Class
from) ->
                      -- We're upcasting, so 'from' is the subclass.
                      Class -> Class -> Class -> Generator ErrorMsg
toHsCastPrimitiveName Class
from Class
from Class
to
                    [ErrorMsg] -> Generator ()
LH.saysLn ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$ [[ErrorMsg]] -> [ErrorMsg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [if Bool
first then ErrorMsg
"[" else ErrorMsg
",",
                                          ErrorMsg
" ( HoppyFHR.ExceptionId ",
                                          Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Int -> ErrorMsg) -> Int -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
ancestorId,
                                          ErrorMsg
", \\(e' :: HoppyF.Ptr ()) -> "]
                                       , ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
intersperse ErrorMsg
" $ " ([ErrorMsg] -> [ErrorMsg]) -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> a -> b
$
                                           ErrorMsg
"HoppyF.castPtr" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
                                           [ErrorMsg]
ancestorCastChain [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++
                                           [ErrorMsg
"HoppyF.castPtr e' :: HoppyF.Ptr ()"]
                                       , [ErrorMsg
")"]
                                       ]
                    [Class] -> (Class -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Class]
classSuperclasses Class
ancestorCls) ((Class -> Generator ()) -> Generator ())
-> (Class -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Class] -> Class -> Generator ()
genCast Bool
False [Class]
path'

            [(Class, Bool)] -> ((Class, Bool) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Class] -> [Bool] -> [(Class, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Class -> [Class]
classSuperclasses Class
cls) (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False)) (((Class, Bool) -> Generator ()) -> Generator ())
-> ((Class, Bool) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$
              \(Class
ancestorCls, Bool
first) -> Bool -> [Class] -> Class -> Generator ()
genCast Bool
first [Class
cls] Class
ancestorCls
            ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"]"

    Generator ()
LH.ln
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"cppExceptionBuild fptr' ptr' = ", ErrorMsg
ctorGcName,
               ErrorMsg
" fptr' (HoppyF.castPtr ptr' :: HoppyF.Ptr ", ErrorMsg
typeName, ErrorMsg
")"]
    Generator ()
LH.ln
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"cppExceptionBuildToGc ptr' = HoppyFHR.toGc $ ", ErrorMsg
ctorName,
               ErrorMsg
" (HoppyF.castPtr ptr' :: HoppyF.Ptr ", ErrorMsg
typeName, ErrorMsg
")"]

  -- Generate a const CppException instance that piggybacks off of the
  -- non-const implementation.
  Generator ()
LH.ln
  [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.CppException ", ErrorMsg
typeNameConst,
             if Bool
doDecls then ErrorMsg
" where" else ErrorMsg
""]
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(.)",
                             HsImportSet
hsImportForPrelude]
    ErrorMsg
constCastFnName <- Constness -> Class -> Generator ErrorMsg
toHsConstCastFnName Constness
Const Class
cls
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"cppExceptionInfo _ = HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",
               ErrorMsg
typeName, ErrorMsg
")"]
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"cppExceptionBuild = (", ErrorMsg
constCastFnName,
               ErrorMsg
" .) . HoppyFHR.cppExceptionBuild"]
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"cppExceptionBuildToGc = HoppyP.fmap ", ErrorMsg
constCastFnName,
               ErrorMsg
" . HoppyFHR.cppExceptionBuildToGc"]

  -- Generate a non-const CppThrowable instance.
  Generator ()
LH.ln
  [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance HoppyFHR.CppThrowable ", ErrorMsg
typeName,
             if Bool
doDecls then ErrorMsg
" where" else ErrorMsg
""]
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    ErrorMsg
ctorName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
    ErrorMsg
ctorGcName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Managed Constness
Nonconst Class
cls
    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
hsImportForForeign,
                             HsImportSet
hsImportForPrelude]
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"toSomeCppException this'@(", ErrorMsg
ctorName, ErrorMsg
" ptr') = ",
               ErrorMsg
"HoppyFHR.SomeCppException (HoppyFHR.cppExceptionInfo this') HoppyP.Nothing ",
               ErrorMsg
"(HoppyF.castPtr ptr')"]
    [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"toSomeCppException this'@(", ErrorMsg
ctorGcName, ErrorMsg
" fptr' ptr') = ",
               ErrorMsg
"HoppyFHR.SomeCppException (HoppyFHR.cppExceptionInfo this') (HoppyP.Just fptr') ",
               ErrorMsg
"(HoppyF.castPtr ptr')"]

sayHsExportClassCastPrimitives :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassCastPrimitives :: SayExportMode -> Class -> Generator ()
sayHsExportClassCastPrimitives SayExportMode
mode Class
cls = ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext ErrorMsg
"generating cast primitives" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  ErrorMsg
clsType <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Const Class
cls
  case SayExportMode
mode of
    SayExportMode
LH.SayExportForeignImports ->
      Class -> (Class -> Generator Bool) -> Generator ()
forAncestors Class
cls ((Class -> Generator Bool) -> Generator ())
-> (Class -> Generator Bool) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Class
super -> do
        ErrorMsg
hsCastFnName <- Class -> Class -> Class -> Generator ErrorMsg
toHsCastPrimitiveName Class
cls Class
cls Class
super
        ErrorMsg
hsDownCastFnName <- Class -> Class -> Class -> Generator ErrorMsg
toHsCastPrimitiveName Class
cls Class
super Class
cls
        ErrorMsg
superType <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Const Class
super
        HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForForeign
        ErrorMsg -> Generator ()
LH.addExport ErrorMsg
hsCastFnName
        [ErrorMsg] -> Generator ()
LH.saysLn [ ErrorMsg
"foreign import ccall \"", Class -> Class -> ErrorMsg
cppCastFnName Class
cls Class
super
                  , ErrorMsg
"\" ", ErrorMsg
hsCastFnName, ErrorMsg
" :: HoppyF.Ptr ", ErrorMsg
clsType, ErrorMsg
" -> HoppyF.Ptr ", ErrorMsg
superType
                  ]
        Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Class -> Bool
classIsSubclassOfMonomorphic Class
cls Bool -> Bool -> Bool
|| Class -> Bool
classIsMonomorphicSuperclass Class
super) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
          ErrorMsg -> Generator ()
LH.addExport ErrorMsg
hsDownCastFnName
          [ErrorMsg] -> Generator ()
LH.saysLn [ ErrorMsg
"foreign import ccall \"", Class -> Class -> ErrorMsg
cppCastFnName Class
super Class
cls
                    , ErrorMsg
"\" ", ErrorMsg
hsDownCastFnName, ErrorMsg
" :: HoppyF.Ptr ", ErrorMsg
superType, ErrorMsg
" -> HoppyF.Ptr "
                    , ErrorMsg
clsType
                    ]
        Bool -> Generator Bool
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    SayExportMode
LH.SayExportDecls ->
      -- Generate a downcast typeclass and instances for all ancestor classes
      -- for the current constness.  These don't need to be in the boot file,
      -- since they're not used by other generated bindings.
      Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Class -> Bool
classIsSubclassOfMonomorphic Class
cls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      [Constness] -> (Constness -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Constness
forall a. Bounded a => a
minBound..] ((Constness -> Generator ()) -> Generator ())
-> (Constness -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Constness
cst -> do
        ErrorMsg
downCastClassName <- Constness -> Class -> Generator ErrorMsg
toHsDownCastClassName Constness
cst Class
cls
        ErrorMsg
downCastMethodName <- Constness -> Class -> Generator ErrorMsg
toHsDownCastMethodName Constness
cst Class
cls
        ErrorMsg
typeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
cst Class
cls
        ErrorMsg -> Generator ()
LH.addExport' ErrorMsg
downCastClassName
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"class ", ErrorMsg
downCastClassName, ErrorMsg
" a where"]
        Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
downCastMethodName, ErrorMsg
" :: ",
                            HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint (HsType -> ErrorMsg) -> HsType -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyFun (HsName -> HsType
HsTyVar (HsName -> HsType) -> HsName -> HsType
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"a") (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$
                            HsQName -> HsType
HsTyCon (HsQName -> HsType) -> HsQName -> HsType
forall a b. (a -> b) -> a -> b
$ HsName -> HsQName
UnQual (HsName -> HsQName) -> HsName -> HsQName
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> HsName
HsIdent ErrorMsg
typeName]
        Generator ()
LH.ln
        Class -> (Class -> Generator Bool) -> Generator ()
forAncestors Class
cls ((Class -> Generator Bool) -> Generator ())
-> (Class -> Generator Bool) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Class
super -> case Class -> Bool
classIsMonomorphicSuperclass Class
super of
          Bool
True -> Bool -> Generator Bool
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          Bool
False -> do
            ErrorMsg
superTypeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
cst Class
super
            ErrorMsg
primitiveCastFn <- Class -> Class -> Class -> Generator ErrorMsg
toHsCastPrimitiveName Class
cls Class
super Class
cls
            [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"instance ", ErrorMsg
downCastClassName, ErrorMsg
" ", ErrorMsg
superTypeName, ErrorMsg
" where"]

            -- If Foo is a superclass of Bar:
            --
            -- instance BarSuper Foo where
            --   downToBar castFooToNonconst . downcast' . castFooToConst
            --     where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr'
            --           downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr'
            --
            -- instance BarSuperConst FooConst where
            --   downToBarConst = downcast'
            --     where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr'
            --           downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr'

            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
              case Constness
cst of
                Constness
Const -> [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
downCastMethodName, ErrorMsg
" = cast'"]
                Constness
Nonconst -> do
                  HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"(.)"
                  ErrorMsg
castClsToNonconst <- Constness -> Class -> Generator ErrorMsg
toHsConstCastFnName Constness
Nonconst Class
cls
                  ErrorMsg
castSuperToConst <- Constness -> Class -> Generator ErrorMsg
toHsConstCastFnName Constness
Const Class
super
                  [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
downCastMethodName, ErrorMsg
" = ", ErrorMsg
castClsToNonconst, ErrorMsg
" . cast' . ",
                             ErrorMsg
castSuperToConst]
              Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
                ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"where"
                Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
                  ErrorMsg
clsCtorName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
                  ErrorMsg
clsCtorGcName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Managed Constness
Const Class
cls
                  ErrorMsg
superCtorName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
super
                  ErrorMsg
superCtorGcName <- Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
LH.Managed Constness
Const Class
super
                  [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"cast' (", ErrorMsg
superCtorName, ErrorMsg
" ptr') = ",
                             ErrorMsg
clsCtorName, ErrorMsg
" $ ", ErrorMsg
primitiveCastFn, ErrorMsg
" ptr'"]
                  [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"cast' (", ErrorMsg
superCtorGcName, ErrorMsg
" fptr' ptr') = ",
                             ErrorMsg
clsCtorGcName , ErrorMsg
" fptr' $ ", ErrorMsg
primitiveCastFn, ErrorMsg
" ptr'"]
            Bool -> Generator Bool
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    SayExportMode
LH.SayExportBoot -> do
      Class -> (Class -> Generator Bool) -> Generator ()
forAncestors Class
cls ((Class -> Generator Bool) -> Generator ())
-> (Class -> Generator Bool) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Class
super -> do
        ErrorMsg
hsCastFnName <- Class -> Class -> Class -> Generator ErrorMsg
toHsCastPrimitiveName Class
cls Class
cls Class
super
        ErrorMsg
superType <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Const Class
super
        HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForForeign
        ErrorMsg -> Generator ()
LH.addExport ErrorMsg
hsCastFnName
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsCastFnName, ErrorMsg
" :: HoppyF.Ptr ", ErrorMsg
clsType, ErrorMsg
" -> HoppyF.Ptr ", ErrorMsg
superType]
        Bool -> Generator Bool
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  where forAncestors :: Class -> (Class -> LH.Generator Bool) -> LH.Generator ()
        forAncestors :: Class -> (Class -> Generator Bool) -> Generator ()
forAncestors Class
cls' Class -> Generator Bool
f = [Class] -> (Class -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Class -> [Class]
classSuperclasses Class
cls') ((Class -> Generator ()) -> Generator ())
-> (Class -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Class
super -> do
          Bool
recur <- Class -> Generator Bool
f Class
super
          Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
recur (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ Class -> (Class -> Generator Bool) -> Generator ()
forAncestors Class
super Class -> Generator Bool
f

getMethodEffectiveParams :: Class -> Method -> [Parameter]
getMethodEffectiveParams :: Class -> Method -> [Parameter]
getMethodEffectiveParams Class
cls Method
method =
  (case Method -> MethodImpl
methodImpl Method
method of
     RealMethod {} -> case Method -> MethodApplicability
methodApplicability Method
method of
       MethodApplicability
MNormal -> ((ErrorMsg
"this" ErrorMsg -> Type -> Parameter
forall a. IsParameter a => ErrorMsg -> a -> Parameter
~: Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) Parameter -> [Parameter] -> [Parameter]
forall a. a -> [a] -> [a]
:)
       MethodApplicability
MConst -> ((ErrorMsg
"this" ErrorMsg -> Type -> Parameter
forall a. IsParameter a => ErrorMsg -> a -> Parameter
~: Type -> Type
ptrT (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) Parameter -> [Parameter] -> [Parameter]
forall a. a -> [a] -> [a]
:)
       MethodApplicability
MStatic -> [Parameter] -> [Parameter]
forall a. a -> a
id
     FnMethod {} -> [Parameter] -> [Parameter]
forall a. a -> a
id) ([Parameter] -> [Parameter]) -> [Parameter] -> [Parameter]
forall a b. (a -> b) -> a -> b
$
  Method -> [Parameter]
methodParams Method
method

getHsClassExceptionId :: Class -> LH.Generator ExceptionId
getHsClassExceptionId :: Class -> Generator ExceptionId
getHsClassExceptionId Class
cls = do
  Interface
iface <- Generator Interface
LH.askInterface
  Generator ExceptionId -> Maybe ExceptionId -> Generator ExceptionId
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (ErrorMsg -> Generator ExceptionId
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg -> Generator ExceptionId)
-> ErrorMsg -> Generator ExceptionId
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ErrorMsg
"Internal error, exception class ", Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
cls, ErrorMsg
" doesn't have an exception ID"]) (Maybe ExceptionId -> Generator ExceptionId)
-> Maybe ExceptionId -> Generator ExceptionId
forall a b. (a -> b) -> a -> b
$
    Interface -> Class -> Maybe ExceptionId
interfaceExceptionClassId Interface
iface Class
cls

-- | The name for the typeclass of types that can be represented as values of
-- the given C++ class.
toHsValueClassName :: Class -> LH.Generator String
toHsValueClassName :: Class -> Generator ErrorMsg
toHsValueClassName Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsValueClassName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ErrorMsg
toHsValueClassName' Class
cls

-- | Pure version of 'toHsValueClassName' that doesn't create a qualified name.
toHsValueClassName' :: Class -> String
toHsValueClassName' :: Class -> ErrorMsg
toHsValueClassName' Class
cls = Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"Value"

-- | The name of the method within the 'toHsValueClassName' typeclass for
-- accessing an object of the type as a pointer.
toHsWithValuePtrName :: Class -> LH.Generator String
toHsWithValuePtrName :: Class -> Generator ErrorMsg
toHsWithValuePtrName Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsWithValuePtrName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ErrorMsg
toHsWithValuePtrName' Class
cls

-- | Pure version of 'toHsWithValuePtrName' that doesn't create a qualified name.
toHsWithValuePtrName' :: Class -> String
toHsWithValuePtrName' :: Class -> ErrorMsg
toHsWithValuePtrName' Class
cls = [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"with", Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls, ErrorMsg
"Ptr"]

-- | The name for the typeclass of types that are (possibly const) pointers to
-- objects of the given C++ class, or subclasses.
toHsPtrClassName :: Constness -> Class -> LH.Generator String
toHsPtrClassName :: Constness -> Class -> Generator ErrorMsg
toHsPtrClassName Constness
cst Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsPtrClassName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsPtrClassName' Constness
cst Class
cls

-- | Pure version of 'toHsPtrClassName' that doesn't create a qualified name.
toHsPtrClassName' :: Constness -> Class -> String
toHsPtrClassName' :: Constness -> Class -> ErrorMsg
toHsPtrClassName' Constness
cst Class
cls = Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
cst Class
cls ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"Ptr"

-- | The name of the function that upcasts pointers to the specific class type
-- and constness.
toHsCastMethodName :: Constness -> Class -> LH.Generator String
toHsCastMethodName :: Constness -> Class -> Generator ErrorMsg
toHsCastMethodName Constness
cst Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsCastMethodName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsCastMethodName' Constness
cst Class
cls

-- | Pure version of 'toHsCastMethodName' that doesn't create a qualified name.
toHsCastMethodName' :: Constness -> Class -> String
toHsCastMethodName' :: Constness -> Class -> ErrorMsg
toHsCastMethodName' Constness
cst Class
cls = ErrorMsg
"to" ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
cst Class
cls

-- | The name of the typeclass that provides a method to downcast to a specific
-- class type.  See 'toHsDownCastMethodName'.
toHsDownCastClassName :: Constness -> Class -> LH.Generator String
toHsDownCastClassName :: Constness -> Class -> Generator ErrorMsg
toHsDownCastClassName Constness
cst Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsDownCastClassName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsDownCastClassName' Constness
cst Class
cls

-- | Pure version of 'toHsDownCastClassName' that doesn't create a qualified
-- name.
toHsDownCastClassName' :: Constness -> Class -> String
toHsDownCastClassName' :: Constness -> Class -> ErrorMsg
toHsDownCastClassName' Constness
cst Class
cls =
  [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls,
          ErrorMsg
"Super",
          case Constness
cst of
            Constness
Const -> ErrorMsg
"Const"
            Constness
Nonconst -> ErrorMsg
""]

-- | The name of the function that downcasts pointers to the specific class type
-- and constness.
toHsDownCastMethodName :: Constness -> Class -> LH.Generator String
toHsDownCastMethodName :: Constness -> Class -> Generator ErrorMsg
toHsDownCastMethodName Constness
cst Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsDownCastMethodName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsDownCastMethodName' Constness
cst Class
cls

-- | Pure version of 'toHsDownCastMethodName' that doesn't create a qualified
-- name.
toHsDownCastMethodName' :: Constness -> Class -> String
toHsDownCastMethodName' :: Constness -> Class -> ErrorMsg
toHsDownCastMethodName' Constness
cst Class
cls = ErrorMsg
"downTo" ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
cst Class
cls

-- | The import name for the foreign function that casts between two specific
-- pointer types.  Used for upcasting and downcasting.
--
-- We need to know which module the cast function resides in, and while we could
-- look this up, the caller always knows, so we just have them pass it in.
toHsCastPrimitiveName :: Class -> Class -> Class -> LH.Generator String
toHsCastPrimitiveName :: Class -> Class -> Class -> Generator ErrorMsg
toHsCastPrimitiveName Class
descendentClass Class
from Class
to =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsCastPrimitiveName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
descendentClass) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> Class -> ErrorMsg
toHsCastPrimitiveName' Class
from Class
to

-- | Pure version of 'toHsCastPrimitiveName' that doesn't create a qualified
-- name.
toHsCastPrimitiveName' :: Class -> Class -> String
toHsCastPrimitiveName' :: Class -> Class -> ErrorMsg
toHsCastPrimitiveName' Class
from Class
to =
  [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"cast", Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
from, ErrorMsg
"To", Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
to]

-- | The name of one of the functions that add/remove const to/from a class's
-- pointer type.  Given 'Const', it will return the function that adds const,
-- and given 'Nonconst', it will return the function that removes const.
toHsConstCastFnName :: Constness -> Class -> LH.Generator String
toHsConstCastFnName :: Constness -> Class -> Generator ErrorMsg
toHsConstCastFnName Constness
cst Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsConstCastFnName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsConstCastFnName' Constness
cst Class
cls

-- | Pure version of 'toHsConstCastFnName' that doesn't create a qualified name.
toHsConstCastFnName' :: Constness -> Class -> String
toHsConstCastFnName' :: Constness -> Class -> ErrorMsg
toHsConstCastFnName' Constness
cst Class
cls =
  [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"cast", Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls,
          case Constness
cst of
            Constness
Const -> ErrorMsg
"ToConst"
            Constness
Nonconst -> ErrorMsg
"ToNonconst"]

-- | The name of the data type that represents a pointer to an object of the
-- given class and constness.
toHsDataTypeName :: Constness -> Class -> LH.Generator String
toHsDataTypeName :: Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
cst Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsDataTypeName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
cst Class
cls

-- | Pure version of 'toHsDataTypeName' that doesn't create a qualified name.
toHsDataTypeName' :: Constness -> Class -> String
toHsDataTypeName' :: Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
cst Class
cls = Constness -> ExtName -> ErrorMsg
LH.toHsTypeName' Constness
cst (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
cls

-- | The name of a data constructor for one of the object pointer types.
toHsDataCtorName :: LH.Managed -> Constness -> Class -> LH.Generator String
toHsDataCtorName :: Managed -> Constness -> Class -> Generator ErrorMsg
toHsDataCtorName Managed
m Constness
cst Class
cls =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsDataCtorName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Managed -> Constness -> Class -> ErrorMsg
toHsDataCtorName' Managed
m Constness
cst Class
cls

-- | Pure version of 'toHsDataCtorName' that doesn't create a qualified name.
toHsDataCtorName' :: LH.Managed -> Constness -> Class -> String
toHsDataCtorName' :: Managed -> Constness -> Class -> ErrorMsg
toHsDataCtorName' Managed
m Constness
cst Class
cls = case Managed
m of
  Managed
LH.Unmanaged -> ErrorMsg
base
  Managed
LH.Managed -> ErrorMsg
base ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"Gc"
  where base :: ErrorMsg
base = Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
cst Class
cls

-- | The name of the foreign function import wrapping @delete@ for the given
-- class type.  This is in internal to the binding; normal users should use
-- 'Foreign.Hoppy.Runtime.delete'.
--
-- This is internal to a generated Haskell module, so it does not have a public
-- (qualified) form.
toHsClassDeleteFnName' :: Class -> String
toHsClassDeleteFnName' :: Class -> ErrorMsg
toHsClassDeleteFnName' Class
cls = Char
'd'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'e'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'l'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'e'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
't'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'e'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls

-- | The name of the foreign import that imports the same function as
-- 'toHsClassDeleteFnName'', but as a 'Foreign.Ptr.FunPtr' rather than an actual
-- function.
--
-- This is internal to a generated Haskell module, so it does not have a public
-- (qualified) form.
toHsClassDeleteFnPtrName' :: Class -> String
toHsClassDeleteFnPtrName' :: Class -> ErrorMsg
toHsClassDeleteFnPtrName' Class
cls =
  Char
'd'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'e'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'l'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'e'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
't'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'e'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'P'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
't'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'r'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:Constness -> Class -> ErrorMsg
toHsDataTypeName' Constness
Nonconst Class
cls

-- | Returns the name of the Haskell function that invokes the given
-- constructor.
toHsCtorName :: Class -> Ctor -> LH.Generator String
toHsCtorName :: Class -> Ctor -> Generator ErrorMsg
toHsCtorName Class
cls Ctor
ctor =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsCtorName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  Class -> ErrorMsg -> Generator ErrorMsg
forall name.
IsFnName ErrorMsg name =>
Class -> name -> Generator ErrorMsg
toHsClassEntityName Class
cls (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Ctor -> ExtName
ctorExtName Ctor
ctor

-- | Pure version of 'toHsCtorName' that doesn't create a qualified name.
toHsCtorName' :: Class -> Ctor -> String
toHsCtorName' :: Class -> Ctor -> ErrorMsg
toHsCtorName' Class
cls Ctor
ctor =
  Class -> ShowS
forall name. IsFnName ErrorMsg name => Class -> name -> ErrorMsg
toHsClassEntityName' Class
cls ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Ctor -> ExtName
ctorExtName Ctor
ctor

-- | Returns the name of the Haskell function that invokes the given method.
toHsMethodName :: Class -> Method -> LH.Generator String
toHsMethodName :: Class -> Method -> Generator ErrorMsg
toHsMethodName Class
cls Method
method =
  ErrorMsg -> Generator ErrorMsg -> Generator ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsMethodName" (Generator ErrorMsg -> Generator ErrorMsg)
-> Generator ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$
  Class -> ErrorMsg -> Generator ErrorMsg
forall name.
IsFnName ErrorMsg name =>
Class -> name -> Generator ErrorMsg
toHsClassEntityName Class
cls (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Method -> ExtName
methodExtName Method
method

-- | Pure version of 'toHsMethodName' that doesn't create a qualified name.
toHsMethodName' :: Class -> Method -> String
toHsMethodName' :: Class -> Method -> ErrorMsg
toHsMethodName' Class
cls Method
method =
  Class -> ShowS
forall name. IsFnName ErrorMsg name => Class -> name -> ErrorMsg
toHsClassEntityName' Class
cls ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Method -> ExtName
methodExtName Method
method

-- | Returns the name of the Haskell function for an entity in a class.
toHsClassEntityName :: IsFnName String name => Class -> name -> LH.Generator String
toHsClassEntityName :: forall name.
IsFnName ErrorMsg name =>
Class -> name -> Generator ErrorMsg
toHsClassEntityName Class
cls name
name =
  ExtName -> ErrorMsg -> Generator ErrorMsg
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (ErrorMsg -> Generator ErrorMsg) -> ErrorMsg -> Generator ErrorMsg
forall a b. (a -> b) -> a -> b
$ Class -> name -> ErrorMsg
forall name. IsFnName ErrorMsg name => Class -> name -> ErrorMsg
toHsClassEntityName' Class
cls name
name

-- | Pure version of 'toHsClassEntityName' that doesn't create a qualified name.
toHsClassEntityName' :: IsFnName String name => Class -> name -> String
toHsClassEntityName' :: forall name. IsFnName ErrorMsg name => Class -> name -> ErrorMsg
toHsClassEntityName' Class
cls name
name =
  ShowS
lowerFirst ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$
  Class -> ExtName -> ExtName
classEntityForeignName' Class
cls (ExtName -> ExtName) -> ExtName -> ExtName
forall a b. (a -> b) -> a -> b
$
  case name -> FnName ErrorMsg
forall t a. IsFnName t a => a -> FnName t
toFnName name
name of
    FnName ErrorMsg
name' -> HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName ErrorMsg
name'
    FnOp Operator
op -> HasCallStack => Operator -> ExtName
Operator -> ExtName
operatorPreferredExtName Operator
op

-- | Generates C++ gateway functions (via 'Function.sayCppExportFn') for getting
-- and setting a variable (possibly a class variable).
sayCppExportVar ::
     Type  -- ^ The type that the variable holds.
  -> Maybe (Type, Type)
     -- ^ @Nothing@ if the variable is not a class variable.  If it is, then the
     -- first type is the generated getter's argument type for the object, and
     -- the second is the generated setter's argument type.  For a class @cls@,
     -- this can be:
     --
     -- > Just ('ptrT' $ 'constT' $ 'objT' cls, 'ptrT' $ 'objT' cls)
  -> Bool
     -- ^ Whether to generate a getter.  Passing false here is useful when a
     -- variable's type can't be sensibly converted to a foreign language's
     -- value.
  -> ExtName
     -- ^ An external name from which to generate a getter function name.
  -> ExtName
     -- ^ An external name from which to generate a setter function name.
  -> LC.Generator ()  -- ^ A C++ generator that emits the variable name.
  -> LC.Generator ()
sayCppExportVar :: Type
-> Maybe (Type, Type)
-> Bool
-> ExtName
-> ExtName
-> Generator ()
-> Generator ()
sayCppExportVar Type
t Maybe (Type, Type)
maybeThisTypes Bool
gettable ExtName
getterName ExtName
setterName Generator ()
sayVarName = do
  let (Bool
isConst, Type
deconstType) = case Type
t of
        Internal_TConst Type
t' -> (Bool
True, Type
t')
        Type
t' -> (Bool
False, Type
t')

  -- Say a getter function.
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
gettable (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    ExtName
-> CppCallType
-> Maybe Type
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Bool
-> Generator ()
Function.sayCppExportFn ExtName
getterName
                            (Generator () -> CppCallType
Function.VarRead Generator ()
sayVarName)
                            (((Type, Type) -> Type) -> Maybe (Type, Type) -> Maybe Type
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type, Type) -> Type
forall a b. (a, b) -> a
fst Maybe (Type, Type)
maybeThisTypes)
                            []
                            Type
deconstType
                            ExceptionHandlers
forall a. Monoid a => a
mempty
                            Bool
True

  -- Say a setter function.
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isConst (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    ExtName
-> CppCallType
-> Maybe Type
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Bool
-> Generator ()
Function.sayCppExportFn ExtName
setterName
                            (Generator () -> CppCallType
Function.VarWrite Generator ()
sayVarName)
                            (((Type, Type) -> Type) -> Maybe (Type, Type) -> Maybe Type
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type, Type) -> Type
forall a b. (a, b) -> b
snd Maybe (Type, Type)
maybeThisTypes)
                            [Type -> Parameter
forall a. IsParameter a => a -> Parameter
toParameter (Type -> Parameter) -> Type -> Parameter
forall a b. (a -> b) -> a -> b
$ Type
deconstType]
                            Type
voidT
                            ExceptionHandlers
forall a. Monoid a => a
mempty
                            Bool
True

-- | Generates Haskell gateway functions (via 'Function.sayHsExportFn') for
-- getting and setting a variable (possibly a class variable).
sayHsExportVar ::
     LH.SayExportMode  -- ^ The phase of code generation.
  -> Type  -- ^ The type that the variable holds.
  -> Maybe Class
     -- ^ The type of the class holding the variable, if generating code for a
     -- class variable.
  -> Bool
     -- ^ Whether to generate a getter.  Passing false here is useful when a
     -- variable's type can't be sensibly converted to a foreign language's
     -- value.
  -> ExtName
     -- ^ An external name for the getter.
  -> ExtName
     -- ^ A foreign external name for the getter.  See 'Function.sayHsExportFn'.
  -> ExtName
     -- ^ An external name for the setter.
  -> ExtName
     -- ^ A foreign external name for the setter.  See 'Function.sayHsExportFn'.
  -> LH.Generator ()
sayHsExportVar :: SayExportMode
-> Type
-> Maybe Class
-> Bool
-> ExtName
-> ExtName
-> ExtName
-> ExtName
-> Generator ()
sayHsExportVar SayExportMode
mode
               Type
t
               Maybe Class
classIfNonstatic
               Bool
gettable
               ExtName
getterExtName
               ExtName
getterForeignName
               ExtName
setterExtName
               ExtName
setterForeignName = do
  let (Bool
isConst, Type
deconstType) = case Type
t of
        Internal_TConst Type
t' -> (Bool
True, Type
t')
        Type
t' -> (Bool
False, Type
t')

  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
gettable (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
Function.sayHsExportFn
    SayExportMode
mode
    ExtName
getterExtName
    ExtName
getterForeignName
    Purity
Nonpure
    ([Parameter] -> (Class -> [Parameter]) -> Maybe Class -> [Parameter]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Class
cls -> [Type -> Parameter
forall a. IsParameter a => a -> Parameter
toParameter (Type -> Parameter) -> Type -> Parameter
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT (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]) Maybe Class
classIfNonstatic)
    Type
deconstType
    ExceptionHandlers
forall a. Monoid a => a
mempty

  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isConst (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Generator ()
Function.sayHsExportFn
    SayExportMode
mode
    ExtName
setterExtName
    ExtName
setterForeignName
    Purity
Nonpure
    ([Parameter] -> (Class -> [Parameter]) -> Maybe Class -> [Parameter]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Type -> Parameter
forall a. IsParameter a => a -> Parameter
toParameter Type
deconstType]
           (\Class
cls -> [Type -> Parameter
forall a. IsParameter a => a -> Parameter
toParameter (Type -> Parameter) -> Type -> Parameter
forall a b. (a -> b) -> a -> b
$ Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls, Type -> Parameter
forall a. IsParameter a => a -> Parameter
toParameter Type
deconstType])
           Maybe Class
classIfNonstatic)
    Type
voidT
    ExceptionHandlers
forall a. Monoid a => a
mempty