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

-- | 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 -> String
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 -> String
show Class
cls =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"<Class ", ExtName -> String
forall a. Show a => a -> String
show (Class -> ExtName
classExtName Class
cls), String
" ", Identifier -> String
forall a. Show a => a -> String
show (Class -> Identifier
classIdentifier Class
cls), String
">"]

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
classReqs = Reqs
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
classAddendum = Addendum
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 :: ExtName
-> Identifier
-> [Class]
-> [ClassEntity]
-> Bool
-> ClassConversion
-> Reqs
-> Addendum
-> Bool
-> Bool
-> Bool
-> String
-> Class
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 :: String
classEntityPrefix = ExtName -> String
fromExtName ExtName
extName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_"
     }

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

-- | Adds constructors to a class.
classAddEntities :: [ClassEntity] -> Class -> Class
classAddEntities :: [ClassEntity] -> Class -> Class
classAddEntities [ClassEntity]
ents Class
cls =
  if [ClassEntity] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassEntity]
ents then Class
cls else Class
cls { classEntities :: [ClassEntity]
classEntities = Class -> [ClassEntity]
classEntities Class
cls [ClassEntity] -> [ClassEntity] -> [ClassEntity]
forall a. [a] -> [a] -> [a]
++ [ClassEntity]
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 :: Bool
classDtorIsPublic = Bool
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 :: Bool
classIsMonomorphicSuperclass = Bool
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 :: Bool
classIsSubclassOfMonomorphic = Bool
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 :: Bool
classIsException = Bool
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 :: (ClassConversion -> ClassConversion) -> Class -> Class
classModifyConversion ClassConversion -> ClassConversion
f Class
cls =
  let cls' :: Class
cls' = Class
cls { classConversion :: ClassConversion
classConversion = ClassConversion -> ClassConversion
f (ClassConversion -> ClassConversion)
-> ClassConversion -> ClassConversion
forall a b. (a -> b) -> a -> b
$ Class -> ClassConversion
classConversion Class
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) ->
      String -> Class
forall a. HasCallStack => String -> a
error (String -> Class) -> String -> Class
forall a b. (a -> b) -> a -> b
$ String
"classModifyConversion: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Class -> String
forall a. Show a => a -> String
show Class
cls' String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
" was given a Haskell-to-C++ or C++-to-Haskell conversion function" String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
" 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 :: Maybe (Generator HsType)
-> Maybe (Generator ())
-> Maybe (Generator ())
-> ClassHaskellConversion
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 :: ClassHaskellConversion
classHaskellConversion = 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 :: Class -> a -> ExtName
classEntityExtName Class
cls a
x =
  HasCallStack => String -> ExtName
String -> ExtName
toExtName (String -> ExtName) -> String -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (Class -> ExtName
classExtName Class
cls) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> String
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 :: 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 => String -> ExtName
String -> ExtName
toExtName (String -> ExtName) -> String -> ExtName
forall a b. (a -> b) -> a -> b
$ Class -> String
classEntityPrefix Class
cls String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> String
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 -> String
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 -> String
show ClassVariable
v =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"<ClassVariable ",
            ExtName -> String
forall a. Show a => a -> String
show (ExtName -> String) -> ExtName -> String
forall a b. (a -> b) -> a -> b
$ ClassVariable -> ExtName
classVarExtName ClassVariable
v, String
" ",
            ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ClassVariable -> String
classVarCName ClassVariable
v, String
" ",
            Staticness -> String
forall a. Show a => a -> String
show (Staticness -> String) -> Staticness -> String
forall a b. (a -> b) -> a -> b
$ ClassVariable -> Staticness
classVarStatic ClassVariable
v, String
" ",
            Type -> String
forall a. Show a => a -> String
show (Type -> String) -> Type -> String
forall a b. (a -> b) -> a -> b
$ ClassVariable -> Type
classVarType ClassVariable
v, String
">"]

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 :: String
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassEntity
makeClassVariable String
cName Maybe ExtName
maybeExtName Type
tp Staticness
static Bool
gettable =
  ClassVariable -> ClassEntity
CEVar (ClassVariable -> ClassEntity) -> ClassVariable -> ClassEntity
forall a b. (a -> b) -> a -> b
$ String
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ String
cName Maybe ExtName
maybeExtName Type
tp Staticness
static Bool
gettable

-- | The unwrapped version of 'makeClassVariable'.
makeClassVariable_ :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ :: String
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ String
cName Maybe ExtName
maybeExtName =
  ExtName -> String -> Type -> Staticness -> Bool -> ClassVariable
ClassVariable (String -> Maybe ExtName -> ExtName
extNameOrString String
cName Maybe ExtName
maybeExtName) String
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 :: String -> 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)
-> (String -> Type -> ClassVariable)
-> String
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Type -> ClassVariable
mkClassVariable_

-- | The unwrapped version of 'mkClassVariable'.
mkClassVariable_ :: String -> Type -> ClassVariable
mkClassVariable_ :: String -> Type -> ClassVariable
mkClassVariable_ String
cName Type
t = String
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ String
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 :: String -> 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)
-> (String -> Type -> ClassVariable)
-> String
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Type -> ClassVariable
mkStaticClassVariable_

-- | The unwrapped version of 'mkStaticClassVariable'.
mkStaticClassVariable_ :: String -> Type -> ClassVariable
mkStaticClassVariable_ :: String -> Type -> ClassVariable
mkStaticClassVariable_ String
cName Type
t = String
-> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ String
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 => String -> ExtName
String -> ExtName
toExtName (String -> ExtName) -> String -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls ClassVariable
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_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 => String -> ExtName
String -> ExtName
toExtName (String -> ExtName) -> String -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls ClassVariable
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_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 => String -> ExtName
String -> ExtName
toExtName (String -> ExtName) -> String -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityExtName Class
cls ClassVariable
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_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 => String -> ExtName
String -> ExtName
toExtName (String -> ExtName) -> String -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (Class -> ClassVariable -> ExtName
forall a. IsClassEntity a => Class -> a -> ExtName
classEntityForeignName Class
cls ClassVariable
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_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 -> String
show Ctor
ctor = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"<Ctor ", ExtName -> String
forall a. Show a => a -> String
show (Ctor -> ExtName
ctorExtName Ctor
ctor), String
" ", [Parameter] -> String
forall a. Show a => a -> String
show (Ctor -> [Parameter]
ctorParams Ctor
ctor), String
">"]

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 :: ExceptionHandlers
ctorExceptionHandlers = ExceptionHandlers -> ExceptionHandlers
f (ExceptionHandlers -> ExceptionHandlers)
-> ExceptionHandlers -> ExceptionHandlers
forall a b. (a -> b) -> a -> b
$ Ctor -> ExceptionHandlers
ctorExceptionHandlers Ctor
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 :: 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_ :: 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 :: String -> [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)
-> (String -> [p] -> Ctor) -> String -> [p] -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [p] -> Ctor
forall p. IsParameter p => String -> [p] -> Ctor
mkCtor_

-- | The unwrapped version of 'mkCtor'.
mkCtor_ :: IsParameter p => String -> [p] -> Ctor
mkCtor_ :: String -> [p] -> Ctor
mkCtor_ String
extName [p]
params = ExtName -> [Parameter] -> Ctor
forall p. IsParameter p => ExtName -> [p] -> Ctor
makeCtor_ (HasCallStack => String -> ExtName
String -> ExtName
toExtName String
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 -> String
show Method
method =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"<Method ", ExtName -> String
forall a. Show a => a -> String
show (Method -> ExtName
methodExtName Method
method), String
" ",
            case Method -> MethodImpl
methodImpl Method
method of
              RealMethod FnName String
name -> FnName String -> String
forall a. Show a => a -> String
show FnName String
name
              FnMethod FnName Identifier
name -> FnName Identifier -> String
forall a. Show a => a -> String
show FnName Identifier
name, String
" ",
            MethodApplicability -> String
forall a. Show a => a -> String
show (Method -> MethodApplicability
methodApplicability Method
method), String
" ",
            Purity -> String
forall a. Show a => a -> String
show (Method -> Purity
methodPurity Method
method), String
" ",
            [Parameter] -> String
forall a. Show a => a -> String
show (Method -> [Parameter]
methodParams Method
method), String
" ",
            Type -> String
forall a. Show a => a -> String
show (Method -> Type
methodReturn Method
method), String
">"]

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 :: ExceptionHandlers
methodExceptionHandlers = ExceptionHandlers -> ExceptionHandlers
f (ExceptionHandlers -> ExceptionHandlers)
-> ExceptionHandlers -> ExceptionHandlers
forall a b. (a -> b) -> a -> b
$ Method -> ExceptionHandlers
methodExceptionHandlers Method
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
/= :: MethodImpl -> MethodImpl -> Bool
$c/= :: MethodImpl -> MethodImpl -> Bool
== :: MethodImpl -> MethodImpl -> Bool
$c== :: MethodImpl -> MethodImpl -> Bool
Eq, Int -> MethodImpl -> ShowS
[MethodImpl] -> ShowS
MethodImpl -> String
(Int -> MethodImpl -> ShowS)
-> (MethodImpl -> String)
-> ([MethodImpl] -> ShowS)
-> Show MethodImpl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MethodImpl] -> ShowS
$cshowList :: [MethodImpl] -> ShowS
show :: MethodImpl -> String
$cshow :: MethodImpl -> String
showsPrec :: Int -> MethodImpl -> ShowS
$cshowsPrec :: Int -> 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
maxBound :: MethodApplicability
$cmaxBound :: MethodApplicability
minBound :: MethodApplicability
$cminBound :: 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
enumFromThenTo :: MethodApplicability
-> MethodApplicability
-> MethodApplicability
-> [MethodApplicability]
$cenumFromThenTo :: MethodApplicability
-> MethodApplicability
-> MethodApplicability
-> [MethodApplicability]
enumFromTo :: MethodApplicability -> MethodApplicability -> [MethodApplicability]
$cenumFromTo :: MethodApplicability -> MethodApplicability -> [MethodApplicability]
enumFromThen :: MethodApplicability -> MethodApplicability -> [MethodApplicability]
$cenumFromThen :: MethodApplicability -> MethodApplicability -> [MethodApplicability]
enumFrom :: MethodApplicability -> [MethodApplicability]
$cenumFrom :: MethodApplicability -> [MethodApplicability]
fromEnum :: MethodApplicability -> Int
$cfromEnum :: MethodApplicability -> Int
toEnum :: Int -> MethodApplicability
$ctoEnum :: Int -> MethodApplicability
pred :: MethodApplicability -> MethodApplicability
$cpred :: MethodApplicability -> MethodApplicability
succ :: MethodApplicability -> MethodApplicability
$csucc :: MethodApplicability -> MethodApplicability
Enum, MethodApplicability -> MethodApplicability -> Bool
(MethodApplicability -> MethodApplicability -> Bool)
-> (MethodApplicability -> MethodApplicability -> Bool)
-> Eq MethodApplicability
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodApplicability -> MethodApplicability -> Bool
$c/= :: MethodApplicability -> MethodApplicability -> Bool
== :: MethodApplicability -> MethodApplicability -> Bool
$c== :: MethodApplicability -> MethodApplicability -> Bool
Eq, Int -> MethodApplicability -> ShowS
[MethodApplicability] -> ShowS
MethodApplicability -> String
(Int -> MethodApplicability -> ShowS)
-> (MethodApplicability -> String)
-> ([MethodApplicability] -> ShowS)
-> Show MethodApplicability
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MethodApplicability] -> ShowS
$cshowList :: [MethodApplicability] -> ShowS
show :: MethodApplicability -> String
$cshow :: MethodApplicability -> String
showsPrec :: Int -> MethodApplicability -> ShowS
$cshowsPrec :: Int -> 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
maxBound :: Staticness
$cmaxBound :: Staticness
minBound :: Staticness
$cminBound :: 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
enumFromThenTo :: Staticness -> Staticness -> Staticness -> [Staticness]
$cenumFromThenTo :: Staticness -> Staticness -> Staticness -> [Staticness]
enumFromTo :: Staticness -> Staticness -> [Staticness]
$cenumFromTo :: Staticness -> Staticness -> [Staticness]
enumFromThen :: Staticness -> Staticness -> [Staticness]
$cenumFromThen :: Staticness -> Staticness -> [Staticness]
enumFrom :: Staticness -> [Staticness]
$cenumFrom :: Staticness -> [Staticness]
fromEnum :: Staticness -> Int
$cfromEnum :: Staticness -> Int
toEnum :: Int -> Staticness
$ctoEnum :: Int -> Staticness
pred :: Staticness -> Staticness
$cpred :: Staticness -> Staticness
succ :: Staticness -> Staticness
$csucc :: Staticness -> Staticness
Enum, Staticness -> Staticness -> Bool
(Staticness -> Staticness -> Bool)
-> (Staticness -> Staticness -> Bool) -> Eq Staticness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Staticness -> Staticness -> Bool
$c/= :: Staticness -> Staticness -> Bool
== :: Staticness -> Staticness -> Bool
$c== :: Staticness -> Staticness -> Bool
Eq, Int -> Staticness -> ShowS
[Staticness] -> ShowS
Staticness -> String
(Int -> Staticness -> ShowS)
-> (Staticness -> String)
-> ([Staticness] -> ShowS)
-> Show Staticness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Staticness] -> ShowS
$cshowList :: [Staticness] -> ShowS
show :: Staticness -> String
$cshow :: Staticness -> String
showsPrec :: Int -> Staticness -> ShowS
$cshowsPrec :: Int -> 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 :: 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 String 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_ :: 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 String -> MethodImpl
RealMethod (FnName String -> MethodImpl) -> FnName String -> MethodImpl
forall a b. (a -> b) -> a -> b
$ name -> FnName String
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 :: name
-> String
-> 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)
-> (String
    -> MethodApplicability -> Purity -> [p] -> Type -> Method)
-> String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> MethodApplicability -> Purity -> [p] -> Type -> Method)
 -> String
 -> MethodApplicability
 -> Purity
 -> [p]
 -> Type
 -> ClassEntity)
-> (name
    -> String
    -> MethodApplicability
    -> Purity
    -> [p]
    -> Type
    -> Method)
-> name
-> String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName Identifier name, IsParameter p) =>
name
-> String -> 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_ :: name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeFnMethod_ name
cName String
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 => String -> ExtName
String -> ExtName
toExtName String
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' :: name -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod' name
name = FnName String
-> Maybe String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall p.
(HasCallStack, IsParameter p) =>
FnName String
-> Maybe String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod''' (name -> FnName String
forall t a. IsFnName t a => a -> FnName t
toFnName name
name) Maybe String
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'' :: name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod'' name
name String
foreignName = FnName String
-> Maybe String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall p.
(HasCallStack, IsParameter p) =>
FnName String
-> Maybe String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod''' (name -> FnName String
forall t a. IsFnName t a => a -> FnName t
toFnName name
name) (Maybe String
 -> MethodApplicability -> Purity -> [p] -> Type -> Method)
-> Maybe String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
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''' :: FnName String
-> Maybe String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod''' (FnName String
"") Maybe String
maybeForeignName MethodApplicability
_ Purity
_ [p]
paramTypes Type
retType =
  String -> Method
forall a. HasCallStack => String -> a
error (String -> Method) -> String -> Method
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"makeMethod''': Given an empty method name with foreign name ",
                  Maybe String -> String
forall a. Show a => a -> String
show Maybe String
maybeForeignName, String
", parameter types ", [p] -> String
forall a. Show a => a -> String
show [p]
paramTypes,
                  String
", and return type ", Type -> String
forall a. Show a => a -> String
show Type
retType, String
"."]
makeMethod''' FnName String
name (Just String
"") MethodApplicability
_ Purity
_ [p]
paramTypes Type
retType =
  String -> Method
forall a. HasCallStack => String -> a
error (String -> Method) -> String -> Method
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"makeMethod''': Given an empty foreign name with method ",
                  FnName String -> String
forall a. Show a => a -> String
show FnName String
name, String
", parameter types ", [p] -> String
forall a. Show a => a -> String
show [p]
paramTypes, String
", and return type ",
                  Type -> String
forall a. Show a => a -> String
show Type
retType, String
"."]
makeMethod''' FnName String
name Maybe String
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 => String -> ExtName
String -> ExtName
toExtName (String -> ExtName) -> Maybe String -> Maybe ExtName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
maybeForeignName) (ExtName -> ExtName) -> ExtName -> ExtName
forall a b. (a -> b) -> a -> b
$ case FnName String
name of
        FnName String
s -> HasCallStack => String -> ExtName
String -> ExtName
toExtName String
s
        FnOp Operator
op -> HasCallStack => Operator -> ExtName
Operator -> ExtName
operatorPreferredExtName Operator
op
  in FnName String
-> ExtName
-> MethodApplicability
-> Purity
-> [Parameter]
-> Type
-> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod_ FnName String
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 :: 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 String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_

-- | The unwrapped version of 'mkMethod'.
mkMethod_ :: (IsFnName String name, IsParameter p)
          => name
          -> [p]
          -> Type
          -> Method
mkMethod_ :: name -> [p] -> Type -> Method
mkMethod_ name
name = name -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName String 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' :: name -> String -> [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)
-> (String -> [p] -> Type -> Method)
-> String
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> [p] -> Type -> Method)
 -> String -> [p] -> Type -> ClassEntity)
-> (name -> String -> [p] -> Type -> Method)
-> name
-> String
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> String -> [p] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> String -> [p] -> Type -> Method
mkMethod'_

-- | The unwrapped version of 'mkMethod''.
mkMethod'_ :: (IsFnName String name, IsParameter p)
           => name
           -> String
           -> [p]
           -> Type
           -> Method
mkMethod'_ :: name -> String -> [p] -> Type -> Method
mkMethod'_ name
cName String
foreignName = name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod'' name
cName String
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 :: 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 String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_

-- | The unwrapped version of 'mkConstMethod'.
mkConstMethod_ :: (IsFnName String name, IsParameter p)
               => name
               -> [p]
               -> Type
               -> Method
mkConstMethod_ :: name -> [p] -> Type -> Method
mkConstMethod_ name
name = name -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName String 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' :: name -> String -> [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)
-> (String -> [p] -> Type -> Method)
-> String
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> [p] -> Type -> Method)
 -> String -> [p] -> Type -> ClassEntity)
-> (name -> String -> [p] -> Type -> Method)
-> name
-> String
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> String -> [p] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> String -> [p] -> Type -> Method
mkConstMethod'_

-- | The unwrapped version of 'mkConstMethod''.
mkConstMethod'_ :: (IsFnName String name, IsParameter p)
                => name
                -> String
                -> [p]
                -> Type
                -> Method
mkConstMethod'_ :: name -> String -> [p] -> Type -> Method
mkConstMethod'_ name
cName String
foreignName = name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod'' name
cName String
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 :: 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 String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkStaticMethod_

-- | The unwrapped version of 'mkStaticMethod'.
mkStaticMethod_ :: (IsFnName String name, IsParameter p)
                => name
                -> [p]
                -> Type
                -> Method
mkStaticMethod_ :: name -> [p] -> Type -> Method
mkStaticMethod_ name
name = name -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName String 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' :: name -> String -> [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)
-> (String -> [p] -> Type -> Method)
-> String
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> [p] -> Type -> Method)
 -> String -> [p] -> Type -> ClassEntity)
-> (name -> String -> [p] -> Type -> Method)
-> name
-> String
-> [p]
-> Type
-> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> String -> [p] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> String -> [p] -> Type -> Method
mkStaticMethod'_

-- | The unwrapped version of 'mkStaticMethod''.
mkStaticMethod'_ :: (IsFnName String name, IsParameter p)
                 => name
                 -> String
                 -> [p]
                 -> Type
                 -> Method
mkStaticMethod'_ :: name -> String -> [p] -> Type -> Method
mkStaticMethod'_ name
cName String
foreignName = name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name
-> String -> MethodApplicability -> Purity -> [p] -> Type -> Method
makeMethod'' name
cName String
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 :: String -> 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)
-> (String -> Type -> Prop) -> String -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Type -> Prop
mkProp_

-- | The unwrapped version of 'mkProp'.
mkProp_ :: String -> Type -> Prop
mkProp_ :: String -> Type -> Prop
mkProp_ String
name Type
t =
  let Char
c:String
cs = String
name
      setName :: String
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]
: String
cs
  in [Method] -> Prop
Prop [ String -> [Parameter] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_ String
name [Parameter]
np Type
t
          , String -> [Type] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_ String
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 :: String -> 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)
-> (String -> Type -> Prop) -> String -> Type -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Type -> Prop
mkStaticProp_

-- | The unwrapped version of 'mkStaticProp'.
mkStaticProp_ :: String -> Type -> Prop
mkStaticProp_ :: String -> Type -> Prop
mkStaticProp_ String
name Type
t =
  let Char
c:String
cs = String
name
      setName :: String
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]
: String
cs
  in [Method] -> Prop
Prop [ String -> [Parameter] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkStaticMethod_ String
name [Parameter]
np Type
t
          , String -> [Type] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkStaticMethod_ String
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 :: String -> ClassEntity
mkBoolIsProp = Prop -> ClassEntity
CEProp (Prop -> ClassEntity) -> (String -> Prop) -> String -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Prop
mkBoolIsProp_

-- | The unwrapped version of 'mkBoolIsProp'.
mkBoolIsProp_ :: String -> Prop
mkBoolIsProp_ :: String -> Prop
mkBoolIsProp_ String
name =
  let Char
c:String
cs = String
name
      name' :: String
name' = Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs
      isName :: String
isName = Char
'i'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
's'Char -> ShowS
forall a. a -> [a] -> [a]
:String
name'
      setName :: String
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]
:String
name'
  in [Method] -> Prop
Prop [ String -> [Parameter] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_ String
isName [Parameter]
np Type
boolT
          , String -> [Type] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_ String
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 :: String -> ClassEntity
mkBoolHasProp = Prop -> ClassEntity
CEProp (Prop -> ClassEntity) -> (String -> Prop) -> String -> ClassEntity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Prop
mkBoolHasProp_

-- | The unwrapped version of 'mkBoolHasProp'.
mkBoolHasProp_ :: String -> Prop
mkBoolHasProp_ :: String -> Prop
mkBoolHasProp_ String
name =
  let Char
c:String
cs = String
name
      name' :: String
name' = Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs
      hasName :: String
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]
:String
name'
      setName :: String
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]
:String
name'
  in [Method] -> Prop
Prop [ String -> [Parameter] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkConstMethod_ String
hasName [Parameter]
np Type
boolT
          , String -> [Type] -> Type -> Method
forall name p.
(IsFnName String name, IsParameter p) =>
name -> [p] -> Type -> Method
mkMethod_ String
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 (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
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"new" Generator () -> Generator () -> Generator ()
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
$
      String -> [String] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (Class -> String
cppDeleteFnName Class
cls)
                     [String
"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
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"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 String
name -> case FnName String
name of
             FnName String
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)
                 String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"::"
               String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
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
          String -> [String] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (Class -> Class -> String
cppCastFnName Class
cls' Class
ancestorCls)
                         [String
"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
$ String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"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
          String -> [String] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (Class -> Class -> String
cppCastFnName Class
ancestorCls Class
cls')
                         [String
"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
            String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
"return dynamic_cast<"
            Maybe [String] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [String] -> Type -> m ()
LC.sayType Maybe [String]
forall a. Maybe a
Nothing Type
clsPtr
            String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say String
">(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 -> String -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => String -> m ()
LC.say (String -> Generator ()) -> String -> Generator ()
forall a b. (a -> b) -> a -> b
$ ClassVariable -> String
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
                                  [String] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [String] -> m ()
LC.says [String
"::", ClassVariable -> String
classVarCName ClassVariable
v])

makeClassCppName :: String -> Class -> String
makeClassCppName :: String -> Class -> String
makeClassCppName String
prefix Class
cls = [String] -> String
LC.makeCppName [String
prefix, ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
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 :: String
cppDeleteFnPrefix = String
"gendel"

-- | Returns the C++ binding function name of the wrapper for the delete method
-- for a class.
cppDeleteFnName :: Class -> String
cppDeleteFnName :: Class -> String
cppDeleteFnName = String -> Class -> String
makeClassCppName String
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 -> String
cppCastFnName Class
from Class
to =
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"gencast__"
         , ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
forall a b. (a -> b) -> a -> b
$ Class -> ExtName
classExtName Class
from
         , String
"__"
         , ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
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 = String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"generating class " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> String
forall a. Show a => a -> String
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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Parameter] -> Method -> [Parameter]
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
         Method -> Type
methodReturn (Method -> ExceptionHandlers -> Generator ())
-> (Method -> ExceptionHandlers) -> Method -> Generator ()
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 = String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"generating Haskell typeclass" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  String
hsTypeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
cst Class
cls
  String
hsValueClassName <- Class -> Generator String
toHsValueClassName Class
cls
  String
hsWithValuePtrName <- Class -> Generator String
toHsWithValuePtrName Class
cls
  String
hsPtrClassName <- Constness -> Class -> Generator String
toHsPtrClassName Constness
cst Class
cls
  String
hsCastMethodName <- Constness -> Class -> Generator String
toHsCastMethodName Constness
cst Class
cls
  let supers :: [Class]
supers = Class -> [Class]
classSuperclasses Class
cls

  [String]
hsSupers <-
    (\[String]
x -> if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
x
           then do HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
                   [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"HoppyFHR.CppPtr"]
           else [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
x) ([String] -> ReaderT Env (WriterT Output (Except String)) [String])
-> ReaderT Env (WriterT Output (Except String)) [String]
-> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    case Constness
cst of
      Constness
Const -> (Class -> Generator String)
-> [Class] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Constness -> Class -> Generator String
toHsPtrClassName Constness
Const) [Class]
supers
      Constness
Nonconst ->
        (:) (String -> [String] -> [String])
-> Generator String
-> ReaderT
     Env (WriterT Output (Except String)) ([String] -> [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Constness -> Class -> Generator String
toHsPtrClassName Constness
Const Class
cls ReaderT Env (WriterT Output (Except String)) ([String] -> [String])
-> ReaderT Env (WriterT Output (Except String)) [String]
-> ReaderT Env (WriterT Output (Except String)) [String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Class -> Generator String)
-> [Class] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Constness -> Class -> Generator String
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
    String -> Generator ()
LH.addExport' String
hsValueClassName
    Generator ()
LH.ln
    [String] -> Generator ()
LH.saysLn [String
"class ", String
hsValueClassName, String
" a where"]
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
      [String] -> Generator ()
LH.saysLn [String
hsWithValuePtrName, String
" :: a -> (", String
hsTypeName, String
" -> HoppyP.IO b) -> HoppyP.IO b"]

    -- Generate instances for all pointer subtypes.
    Generator ()
LH.ln
    [String] -> Generator ()
LH.saysLn [String
"instance {-# OVERLAPPABLE #-} ", String
hsPtrClassName, String
" a => ", String
hsValueClassName, String
" a",
               if Bool
doDecls then String
" where" else String
""]
    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 [String -> [String] -> HsImportSet
hsImports String
"Prelude" [String
"($)", String
"(.)"],
                               HsImportSet
hsImportForPrelude]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> Generator ()
LH.saysLn [String
hsWithValuePtrName, String
" = HoppyP.flip ($) . ", String
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
        [String] -> Generator ()
LH.saysLn [String
"instance {-# OVERLAPPING #-} ", String
hsValueClassName,
                   String
" (", HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
hsType, String
")", if Bool
doDecls then String
" where" else String
""]
        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
$ [String] -> Generator ()
LH.saysLn [String
hsWithValuePtrName, String
" = HoppyFHR.withCppObj"]
      (Maybe (Generator HsType), Maybe (Generator ()))
_ -> () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Print the pointer class definition.
  String -> Generator ()
LH.addExport' String
hsPtrClassName
  Generator ()
LH.ln
  [String] -> Generator ()
LH.saysLn ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$
    String
"class (" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" this") [String]
hsSupers) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
") => ", String
hsPtrClassName, String
" this where"]
  Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> Generator ()
LH.saysLn [String
hsCastMethodName, String
" :: this -> ", String
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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Parameter] -> Method -> [Parameter]
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
       Method -> Type
methodReturn (Method -> ExceptionHandlers -> Generator ())
-> (Method -> ExceptionHandlers) -> Method -> Generator ()
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 (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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Method -> Type
methodReturn (Method -> ExceptionHandlers -> Generator ())
-> (Method -> ExceptionHandlers) -> Method -> Generator ()
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 = String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"generating Haskell data types" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  String
hsTypeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
cst Class
cls
  String
hsCtor <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged Constness
cst Class
cls
  String
hsCtorGc <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Managed Constness
cst Class
cls
  String
constCastFnName <- Constness -> Class -> Generator String
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.
  String -> Generator ()
LH.addExport' String
hsTypeName
  Generator ()
LH.ln
  [String] -> Generator ()
LH.saysLn [String
"data ", String
hsTypeName, String
" ="]
  Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    [String] -> Generator ()
LH.saysLn [String
"  ", String
hsCtor, String
" (HoppyF.Ptr ", String
hsTypeName, String
")"]
    [String] -> Generator ()
LH.saysLn [String
"| ", String
hsCtorGc, String
" (HoppyF.ForeignPtr ()) (HoppyF.Ptr ", String
hsTypeName, String
")"]
  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
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(==)"
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
LH.sayLn String
"deriving (HoppyP.Show)"
    Generator ()
LH.ln
    [String] -> Generator ()
LH.saysLn [String
"instance HoppyP.Eq ", String
hsTypeName, String
" where"]
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> Generator ()
LH.saysLn [String
"x == y = HoppyFHR.toPtr x == HoppyFHR.toPtr y"]
    Generator ()
LH.ln
    [String] -> Generator ()
LH.saysLn [String
"instance HoppyP.Ord ", String
hsTypeName, String
" where"]
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> Generator ()
LH.saysLn [String
"compare x y = HoppyP.compare (HoppyFHR.toPtr x) (HoppyFHR.toPtr y)"]

  -- Generate const_cast functions:
  --   castFooToConst :: Foo -> FooConst
  --   castFooToNonconst :: FooConst -> Foo
  String
hsTypeNameOppConst <- Constness -> Class -> Generator String
toHsDataTypeName (Constness -> Constness
constNegate Constness
cst) Class
cls
  Generator ()
LH.ln
  String -> Generator ()
LH.addExport String
constCastFnName
  [String] -> Generator ()
LH.saysLn [String
constCastFnName, String
" :: ", String
hsTypeNameOppConst, String
" -> ", String
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
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)"
    String
hsCtorOppConst <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged (Constness -> Constness
constNegate Constness
cst) Class
cls
    String
hsCtorGcOppConst <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Managed (Constness -> Constness
constNegate Constness
cst) Class
cls
    [String] -> Generator ()
LH.saysLn [String
constCastFnName, String
" (", String
hsCtorOppConst,
               String
" ptr') = ", String
hsCtor, String
" $ HoppyF.castPtr ptr'"]
    [String] -> Generator ()
LH.saysLn [String
constCastFnName, String
" (", String
hsCtorGcOppConst,
               String
" fptr' ptr') = ", String
hsCtorGc, String
" 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
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)"
            [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.CppPtr ", String
hsTypeName, String
" where"]
            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
              [String] -> Generator ()
LH.saysLn [String
"nullptr = ", String
hsCtor, String
" HoppyF.nullPtr"]
              Generator ()
LH.ln
              [String] -> Generator ()
LH.saysLn [String
"withCppPtr (", String
hsCtor, String
" ptr') f' = f' ptr'"]
              [String] -> Generator ()
LH.saysLn [String
"withCppPtr (", String
hsCtorGc,
                         String
" fptr' ptr') f' = HoppyF.withForeignPtr fptr' $ \\_ -> f' ptr'"]
              Generator ()
LH.ln
              [String] -> Generator ()
LH.saysLn [String
"toPtr (", String
hsCtor, String
" ptr') = ptr'"]
              [String] -> Generator ()
LH.saysLn [String
"toPtr (", String
hsCtorGc, String
" _ ptr') = ptr'"]
              Generator ()
LH.ln
              [String] -> Generator ()
LH.saysLn [String
"touchCppPtr (", String
hsCtor, String
" _) = HoppyP.return ()"]
              [String] -> Generator ()
LH.saysLn [String
"touchCppPtr (", String
hsCtorGc, String
" 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
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(==)"
              Generator ()
LH.ln
              [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Deletable ", String
hsTypeName, String
" 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 ->
                    [String] -> Generator ()
LH.saysLn [String
"delete (", String
hsCtor, String
" ptr') = ", Class -> String
toHsClassDeleteFnName' Class
cls, String
" ptr'"]
                  Constness
Nonconst -> do
                    String
constTypeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Const Class
cls
                    [String] -> Generator ()
LH.saysLn [String
"delete (",String
hsCtor, String
" ptr') = ", Class -> String
toHsClassDeleteFnName' Class
cls,
                               String
" $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ", String
constTypeName, String
")"]
                [String] -> Generator ()
LH.saysLn [String
"delete (", String
hsCtorGc,
                           String
" _ _) = HoppyP.fail $ HoppyP.concat ",
                           String
"[\"Deletable.delete: Asked to delete a GC-managed \", ",
                           ShowS
forall a. Show a => a -> String
show String
hsTypeName, String
", \" object.\"]"]
                Generator ()
LH.ln
                [String] -> Generator ()
LH.saysLn [String
"toGc this'@(", String
hsCtor, String
" ptr') = ",
                           -- No sense in creating a ForeignPtr for a null pointer.
                           String
"if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ",
                           String
"(HoppyP.flip ", String
hsCtorGc, String
" ptr') $ ",
                           String
"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.
                           String
"(HoppyF.castFunPtr ", Class -> String
toHsClassDeleteFnPtrName' Class
cls,
                           String
" :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",
                           String
"(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"]
                [String] -> Generator ()
LH.saysLn [String
"toGc this'@(", String
hsCtorGc, String
" {}) = 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
              String
copyCtorName <- Class -> Ctor -> Generator String
toHsCtorName Class
cls Ctor
copyCtor
              Generator ()
LH.ln
              [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Copyable ", String
hsTypeName, String
" ",
                         case Constness
cst of
                           Constness
Nonconst -> String
hsTypeName
                           Constness
Const -> String
hsTypeNameOppConst,
                         String
" where copy = ", String
copyCtorName]

    else do [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.CppPtr ", String
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
$
              [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Deletable ", String
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
_ ->
              [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Copyable ", String
hsTypeName, String
" ",
                         case Constness
cst of
                           Constness
Nonconst -> String
hsTypeName
                           Constness
Const -> String
hsTypeNameOppConst]

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

  where genInstances :: String -> [Class] -> Class -> LH.Generator ()
        genInstances :: String -> [Class] -> Class -> Generator ()
genInstances String
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
            String
ancestorPtrClassName <- Constness -> Class -> Generator String
toHsPtrClassName Constness
ancestorCst Class
ancestorCls
            [String] -> Generator ()
LH.saysLn [String
"instance ", String
ancestorPtrClassName, String
" ", String
hsTypeName,
                       if Bool
doDecls then String
" where" else String
""]
            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 :: String
castMethodName = Constness -> Class -> String
toHsCastMethodName' Constness
ancestorCst Class
ancestorCls
              if [Class] -> 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
                        [String] -> Generator ()
LH.saysLn [String
castMethodName, String
" = 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
                          [String]
ancestorCtor <- case Managed
managed of
                            Managed
LH.Unmanaged -> (\String
x -> [String
x]) (String -> [String])
-> Generator String
-> ReaderT Env (WriterT Output (Except String)) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                            Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged Constness
ancestorCst Class
ancestorCls
                            Managed
LH.Managed -> (\String
x -> [String
x, String
" fptr'"]) (String -> [String])
-> Generator String
-> ReaderT Env (WriterT Output (Except String)) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                          Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Managed Constness
ancestorCst Class
ancestorCls
                          [String]
ptrPattern <- case Managed
managed of
                            Managed
LH.Unmanaged -> (\String
x -> [String
x, String
" ptr'"]) (String -> [String])
-> Generator String
-> ReaderT Env (WriterT Output (Except String)) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                            Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged Constness
cst Class
cls
                            Managed
LH.Managed -> (\String
x -> [String
x, String
" fptr' ptr'"]) (String -> [String])
-> Generator String
-> ReaderT Env (WriterT Output (Except String)) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                          Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Managed Constness
cst Class
cls
                          [String] -> Generator ()
LH.saysLn ([String] -> Generator ())
-> ([[String]] -> [String]) -> [[String]] -> Generator ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> Generator ())
-> ReaderT Env (WriterT Output (Except String)) [[String]]
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ReaderT Env (WriterT Output (Except String)) [String]]
-> ReaderT Env (WriterT Output (Except String)) [[String]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                            [ [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> ReaderT Env (WriterT Output (Except String)) [String])
-> [String]
-> ReaderT Env (WriterT Output (Except String)) [String]
forall a b. (a -> b) -> a -> b
$
                              [String
castMethodName, String
" ("] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ptrPattern [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
") = "] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ancestorCtor
                            , if Bool
removeConst
                              then do String
ancestorConstType <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Const Class
ancestorCls
                                      String
ancestorNonconstType <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Nonconst Class
ancestorCls
                                      [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
" $ (HoppyF.castPtr :: HoppyF.Ptr ",
                                              String
ancestorConstType, String
" -> HoppyF.Ptr ",
                                              String
ancestorNonconstType, String
")"]
                              else [String] -> ReaderT Env (WriterT Output (Except String)) [String]
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 (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
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)"
                                      String
castPrimitiveName <- Class -> Class -> Class -> Generator String
toHsCastPrimitiveName Class
cls Class
cls Class
ancestorCls
                                      [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
" $ ", String
castPrimitiveName]
                              else [String] -> ReaderT Env (WriterT Output (Except String)) [String]
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
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)"
                                      String
nonconstTypeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Nonconst Class
cls
                                      String
constTypeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Const Class
cls
                                      [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
" $ (HoppyF.castPtr :: HoppyF.Ptr ",
                                              String
nonconstTypeName, String
" -> HoppyF.Ptr ",
                                              String
constTypeName, String
")"]
                              else [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                            , [String] -> ReaderT Env (WriterT Output (Except String)) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
" 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
$
            String -> [Class] -> Class -> Generator ()
genInstances String
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 =
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext (String
"generating variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> String
forall a. Show a => a -> String
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 =
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
   Purity -> Ctor -> Purity
forall (f :: * -> *) a. Applicative f => a -> f a
pure Purity
Nonpure (Ctor -> [Parameter] -> Type -> ExceptionHandlers -> Generator ())
-> (Ctor -> [Parameter])
-> Ctor
-> Type
-> ExceptionHandlers
-> Generator ()
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Ctor -> Type
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 (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
  String
typeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Nonconst Class
cls
  String
typeNameConst <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Const Class
cls

  -- Say the delete function.
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"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]
        [String] -> Generator ()
LH.saysLn [String
"foreign import ccall \"", Class -> String
cppDeleteFnName Class
cls, String
"\" ",
                   Class -> String
toHsClassDeleteFnName' Class
cls, String
" :: HoppyF.Ptr ",
                   String
typeNameConst, String
" -> HoppyP.IO ()"]
        [String] -> Generator ()
LH.saysLn [String
"foreign import ccall \"&", Class -> String
cppDeleteFnName Class
cls, String
"\" ",
                   Class -> String
toHsClassDeleteFnPtrName' Class
cls, String
" :: HoppyF.FunPtr (HoppyF.Ptr ",
                   String
typeNameConst, String
" -> HoppyP.IO ())"]
      -- The user interface to this is the generic 'delete' function, rendered
      -- elsewhere.
      SayExportMode
LH.SayExportDecls -> () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SayExportMode
LH.SayExportBoot -> () -> Generator ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"generating pointer Assignable instance" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    case SayExportMode
mode of
      SayExportMode
LH.SayExportForeignImports -> () -> Generator ()
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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"($)",
                                 HsImportSet
hsImportForForeign,
                                 HsImportSet
hsImportForRuntime]
        Generator ()
LH.ln
        [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Assignable (HoppyF.Ptr (HoppyF.Ptr ", String
typeName, String
")) ",
                   String
typeName, String
" where"]
        Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> Generator ()
LH.sayLn String
"assign ptr' value' = HoppyF.poke ptr' $ HoppyFHR.toPtr value'"
      SayExportMode
LH.SayExportBoot -> () -> Generator ()
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.
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"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 String
name -> FnName String
name FnName String -> FnName String -> Bool
forall a. Eq a => a -> a -> Bool
== Operator -> FnName String
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 (m :: * -> *) a. Monad m => a -> m a
return ()
          [Method
m] -> Method -> m ()
f Method
m
          [Method]
_ ->
            String -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [String
"Can't determine an Assignable instance to generator for ", Class -> String
forall a. Show a => a -> String
show Class
cls,
            String
" because it has multiple assignment operators ", [Method] -> String
forall a. Show a => a -> String
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 String 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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(>>)", HsImportSet
hsImportForPrelude]
      String
valueClassName <- Class -> Generator String
toHsValueClassName Class
cls
      String
assignmentMethodName <- Class -> Method -> Generator String
toHsMethodName Class
cls Method
m
      Generator ()
LH.ln
      [String] -> Generator ()
LH.saysLn [String
"instance ", String
valueClassName, String
" a => HoppyFHR.Assignable ", String
typeName, String
" a where"]
      Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
        [String] -> Generator ()
LH.saysLn [String
"assign x' y' = ", String
assignmentMethodName, String
" 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.
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"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 (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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(.)",
                                 HsImportSet
hsImportForForeign,
                                 HsImportSet
hsImportForPrelude,
                                 HsImportSet
hsImportForRuntime]
        Generator ()
LH.ln
        [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ",
                   String
typeName, String
")) ", String
typeName, String
" where"]
        Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
          String
ctorName <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
          [String] -> Generator ()
LH.saysLn [String
"decode = HoppyP.fmap ", String
ctorName, String
" . 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.
        [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", String
typeName, String
")) ",
                   String
typeName]

  -- Say Encodable and Decodable instances, if the class is encodable and
  -- decodable.
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"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 String
hsTypeStrGen = Generator HsType
hsTypeGen Generator HsType
-> (HsType -> Generator String) -> Generator String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \HsType
hsType -> String -> Generator String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint HsType
hsType String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

      case SayExportMode
mode of
        SayExportMode
LH.SayExportForeignImports -> () -> Generator ()
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
            String
hsTypeStr <- Generator String
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]
            String
castMethodName <- Constness -> Class -> Generator String
toHsCastMethodName Constness
Const Class
cls

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

          -- 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
            String
hsTypeStr <- Generator String
hsTypeStrGen
            HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
            String
castMethodName <- Constness -> Class -> Generator String
toHsCastMethodName Constness
Const Class
cls

            Generator ()
LH.ln
            [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Decodable ", String
typeName, String
" ", String
hsTypeStr, String
" where"]
            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
              [String] -> Generator ()
LH.saysLn [String
"decode = HoppyFHR.decode . ", String
castMethodName]
            Generator ()
LH.ln
            [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Decodable ", String
typeNameConst, String
" ", String
hsTypeStr, String
" where"]
            Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
              String -> Generator ()
LH.sayLn String
"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
            String
hsTypeStr <- Generator String
hsTypeStrGen
            HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
            Generator ()
LH.ln
            [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Encodable ", String
typeName, String
" (", String
hsTypeStr, String
")"]
            [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Encodable ", String
typeNameConst, String
" (", String
hsTypeStr, String
")"]

          -- 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
            String
hsTypeStr <- Generator String
hsTypeStrGen
            HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForRuntime
            Generator ()
LH.ln
            [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Decodable ", String
typeName, String
" (", String
hsTypeStr, String
")"]
            [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Decodable ", String
typeNameConst, String
" (", String
hsTypeStr, String
")"]

-- | 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
$
  String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"generating exception support" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  String
typeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Nonconst Class
cls
  String
typeNameConst <- Constness -> Class -> Generator String
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
  [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.CppException ", String
typeName,
             if Bool
doDecls then String
" where" else String
""]
  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
    String
ctorName <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
    String
ctorGcName <- Managed -> Constness -> Class -> Generator String
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 [String -> [String] -> HsImportSet
hsImports String
"Prelude" [String
"($)", String
"(.)", String
"(=<<)"],
                             HsImportSet
hsImportForForeign,
                             HsImportSet
hsImportForMap,
                             HsImportSet
hsImportForPrelude]
    String -> Generator ()
LH.sayLn String
"cppExceptionInfo _ ="
    Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
      [String] -> Generator ()
LH.saysLn [String
"HoppyFHR.ExceptionClassInfo (HoppyFHR.ExceptionId ",
                 Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
exceptionId, String
") ", ShowS
forall a. Show a => a -> String
show String
typeName,
                 String
" upcasts' delete' copy' toGc'"]

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

      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
        [String] -> Generator ()
LH.saysLn [String
"copy' = HoppyP.fmap (HoppyF.castPtr . HoppyFHR.toPtr) . HoppyFHR.copy . ",
                   String
ctorName, String
" . HoppyF.castPtr"]

        Generator ()
LH.ln
        [String] -> Generator ()
LH.saysLn [String
"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.
                   String
"(HoppyF.castFunPtr ", Class -> String
toHsClassDeleteFnPtrName' Class
cls,
                   String
" :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",
                   String
"ptr'"]

        String -> Generator ()
LH.sayLn String
"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
          [] -> String -> Generator ()
LH.sayLn String
"[]"
          [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
                    [String]
ancestorCastChain <- [(Class, Class)]
-> ((Class, Class) -> Generator String)
-> ReaderT Env (WriterT Output (Except String)) [String]
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 String)
 -> ReaderT Env (WriterT Output (Except String)) [String])
-> ((Class, Class) -> Generator String)
-> ReaderT Env (WriterT Output (Except String)) [String]
forall a b. (a -> b) -> a -> b
$ \(Class
to, Class
from) ->
                      -- We're upcasting, so 'from' is the subclass.
                      Class -> Class -> Class -> Generator String
toHsCastPrimitiveName Class
from Class
from Class
to
                    [String] -> Generator ()
LH.saysLn ([String] -> Generator ()) -> [String] -> Generator ()
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [if Bool
first then String
"[" else String
",",
                                          String
" ( HoppyFHR.ExceptionId ",
                                          Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
ancestorId,
                                          String
", \\(e' :: HoppyF.Ptr ()) -> "]
                                       , String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" $ " ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                                           String
"HoppyF.castPtr" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                                           [String]
ancestorCastChain [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                                           [String
"HoppyF.castPtr e' :: HoppyF.Ptr ()"]
                                       , [String
")"]
                                       ]
                    [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
            String -> Generator ()
LH.sayLn String
"]"

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

  -- Generate a const CppException instance that piggybacks off of the
  -- non-const implementation.
  Generator ()
LH.ln
  [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.CppException ", String
typeNameConst,
             if Bool
doDecls then String
" where" else String
""]
  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 [String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(.)",
                             HsImportSet
hsImportForPrelude]
    String
constCastFnName <- Constness -> Class -> Generator String
toHsConstCastFnName Constness
Const Class
cls
    [String] -> Generator ()
LH.saysLn [String
"cppExceptionInfo _ = HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",
               String
typeName, String
")"]
    [String] -> Generator ()
LH.saysLn [String
"cppExceptionBuild = (", String
constCastFnName,
               String
" .) . HoppyFHR.cppExceptionBuild"]
    [String] -> Generator ()
LH.saysLn [String
"cppExceptionBuildToGc = HoppyP.fmap ", String
constCastFnName,
               String
" . HoppyFHR.cppExceptionBuildToGc"]

  -- Generate a non-const CppThrowable instance.
  Generator ()
LH.ln
  [String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.CppThrowable ", String
typeName,
             if Bool
doDecls then String
" where" else String
""]
  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
    String
ctorName <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged Constness
Nonconst Class
cls
    String
ctorGcName <- Managed -> Constness -> Class -> Generator String
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]
    [String] -> Generator ()
LH.saysLn [String
"toSomeCppException this'@(", String
ctorName, String
" ptr') = ",
               String
"HoppyFHR.SomeCppException (HoppyFHR.cppExceptionInfo this') HoppyP.Nothing ",
               String
"(HoppyF.castPtr ptr')"]
    [String] -> Generator ()
LH.saysLn [String
"toSomeCppException this'@(", String
ctorGcName, String
" fptr' ptr') = ",
               String
"HoppyFHR.SomeCppException (HoppyFHR.cppExceptionInfo this') (HoppyP.Just fptr') ",
               String
"(HoppyF.castPtr ptr')"]

sayHsExportClassCastPrimitives :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassCastPrimitives :: SayExportMode -> Class -> Generator ()
sayHsExportClassCastPrimitives SayExportMode
mode Class
cls = String -> Generator () -> Generator ()
forall a. String -> Generator a -> Generator a
LH.withErrorContext String
"generating cast primitives" (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
  String
clsType <- Constness -> Class -> Generator String
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
        String
hsCastFnName <- Class -> Class -> Class -> Generator String
toHsCastPrimitiveName Class
cls Class
cls Class
super
        String
hsDownCastFnName <- Class -> Class -> Class -> Generator String
toHsCastPrimitiveName Class
cls Class
super Class
cls
        String
superType <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Const Class
super
        HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForForeign
        String -> Generator ()
LH.addExport String
hsCastFnName
        [String] -> Generator ()
LH.saysLn [ String
"foreign import ccall \"", Class -> Class -> String
cppCastFnName Class
cls Class
super
                  , String
"\" ", String
hsCastFnName, String
" :: HoppyF.Ptr ", String
clsType, String
" -> HoppyF.Ptr ", String
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
          String -> Generator ()
LH.addExport String
hsDownCastFnName
          [String] -> Generator ()
LH.saysLn [ String
"foreign import ccall \"", Class -> Class -> String
cppCastFnName Class
super Class
cls
                    , String
"\" ", String
hsDownCastFnName, String
" :: HoppyF.Ptr ", String
superType, String
" -> HoppyF.Ptr "
                    , String
clsType
                    ]
        Bool -> Generator Bool
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
        String
downCastClassName <- Constness -> Class -> Generator String
toHsDownCastClassName Constness
cst Class
cls
        String
downCastMethodName <- Constness -> Class -> Generator String
toHsDownCastMethodName Constness
cst Class
cls
        String
typeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
cst Class
cls
        String -> Generator ()
LH.addExport' String
downCastClassName
        Generator ()
LH.ln
        [String] -> Generator ()
LH.saysLn [String
"class ", String
downCastClassName, String
" a where"]
        Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ [String] -> Generator ()
LH.saysLn [String
downCastMethodName, String
" :: ",
                            HsType -> String
forall a. Pretty a => a -> String
LH.prettyPrint (HsType -> String) -> HsType -> String
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
$ String -> HsName
HsIdent String
"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
$ String -> HsName
HsIdent String
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          Bool
False -> do
            String
superTypeName <- Constness -> Class -> Generator String
toHsDataTypeName Constness
cst Class
super
            String
primitiveCastFn <- Class -> Class -> Class -> Generator String
toHsCastPrimitiveName Class
cls Class
super Class
cls
            [String] -> Generator ()
LH.saysLn [String
"instance ", String
downCastClassName, String
" ", String
superTypeName, String
" 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 -> [String] -> Generator ()
LH.saysLn [String
downCastMethodName, String
" = cast'"]
                Constness
Nonconst -> do
                  HsImportSet -> Generator ()
LH.addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ String -> String -> HsImportSet
hsImport1 String
"Prelude" String
"(.)"
                  String
castClsToNonconst <- Constness -> Class -> Generator String
toHsConstCastFnName Constness
Nonconst Class
cls
                  String
castSuperToConst <- Constness -> Class -> Generator String
toHsConstCastFnName Constness
Const Class
super
                  [String] -> Generator ()
LH.saysLn [String
downCastMethodName, String
" = ", String
castClsToNonconst, String
" . cast' . ",
                             String
castSuperToConst]
              Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
                String -> Generator ()
LH.sayLn String
"where"
                Generator () -> Generator ()
forall a. Generator a -> Generator a
LH.indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
                  String
clsCtorName <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
cls
                  String
clsCtorGcName <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Managed Constness
Const Class
cls
                  String
superCtorName <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Unmanaged Constness
Const Class
super
                  String
superCtorGcName <- Managed -> Constness -> Class -> Generator String
toHsDataCtorName Managed
LH.Managed Constness
Const Class
super
                  [String] -> Generator ()
LH.saysLn [String
"cast' (", String
superCtorName, String
" ptr') = ",
                             String
clsCtorName, String
" $ ", String
primitiveCastFn, String
" ptr'"]
                  [String] -> Generator ()
LH.saysLn [String
"cast' (", String
superCtorGcName, String
" fptr' ptr') = ",
                             String
clsCtorGcName , String
" fptr' $ ", String
primitiveCastFn, String
" ptr'"]
            Bool -> Generator Bool
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
        String
hsCastFnName <- Class -> Class -> Class -> Generator String
toHsCastPrimitiveName Class
cls Class
cls Class
super
        String
superType <- Constness -> Class -> Generator String
toHsDataTypeName Constness
Const Class
super
        HsImportSet -> Generator ()
LH.addImports HsImportSet
hsImportForForeign
        String -> Generator ()
LH.addExport String
hsCastFnName
        [String] -> Generator ()
LH.saysLn [String
hsCastFnName, String
" :: HoppyF.Ptr ", String
clsType, String
" -> HoppyF.Ptr ", String
superType]
        Bool -> Generator Bool
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 -> ((String
"this" String -> Type -> Parameter
forall a. IsParameter a => String -> 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 -> ((String
"this" String -> Type -> Parameter
forall a. IsParameter a => String -> 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 (String -> Generator ExceptionId
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Generator ExceptionId)
-> String -> Generator ExceptionId
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [String
"Internal error, exception class ", Class -> String
forall a. Show a => a -> String
show Class
cls, String
" 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 String
toHsValueClassName Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsValueClassName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Class -> String
toHsValueClassName' Class
cls

-- | Pure version of 'toHsValueClassName' that doesn't create a qualified name.
toHsValueClassName' :: Class -> String
toHsValueClassName' :: Class -> String
toHsValueClassName' Class
cls = Constness -> Class -> String
toHsDataTypeName' Constness
Nonconst Class
cls String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"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 String
toHsWithValuePtrName Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsWithValuePtrName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Class -> String
toHsWithValuePtrName' Class
cls

-- | Pure version of 'toHsWithValuePtrName' that doesn't create a qualified name.
toHsWithValuePtrName' :: Class -> String
toHsWithValuePtrName' :: Class -> String
toHsWithValuePtrName' Class
cls = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"with", Constness -> Class -> String
toHsDataTypeName' Constness
Nonconst Class
cls, String
"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 String
toHsPtrClassName Constness
cst Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsPtrClassName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsPtrClassName' Constness
cst Class
cls

-- | Pure version of 'toHsPtrClassName' that doesn't create a qualified name.
toHsPtrClassName' :: Constness -> Class -> String
toHsPtrClassName' :: Constness -> Class -> String
toHsPtrClassName' Constness
cst Class
cls = Constness -> Class -> String
toHsDataTypeName' Constness
cst Class
cls String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"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 String
toHsCastMethodName Constness
cst Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsCastMethodName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsCastMethodName' Constness
cst Class
cls

-- | Pure version of 'toHsCastMethodName' that doesn't create a qualified name.
toHsCastMethodName' :: Constness -> Class -> String
toHsCastMethodName' :: Constness -> Class -> String
toHsCastMethodName' Constness
cst Class
cls = String
"to" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Constness -> Class -> String
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 String
toHsDownCastClassName Constness
cst Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsDownCastClassName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsDownCastClassName' Constness
cst Class
cls

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

-- | 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 String
toHsDownCastMethodName Constness
cst Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsDownCastMethodName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsDownCastMethodName' Constness
cst Class
cls

-- | Pure version of 'toHsDownCastMethodName' that doesn't create a qualified
-- name.
toHsDownCastMethodName' :: Constness -> Class -> String
toHsDownCastMethodName' :: Constness -> Class -> String
toHsDownCastMethodName' Constness
cst Class
cls = String
"downTo" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Constness -> Class -> String
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 String
toHsCastPrimitiveName Class
descendentClass Class
from Class
to =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsCastPrimitiveName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
descendentClass) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Class -> Class -> String
toHsCastPrimitiveName' Class
from Class
to

-- | Pure version of 'toHsCastPrimitiveName' that doesn't create a qualified
-- name.
toHsCastPrimitiveName' :: Class -> Class -> String
toHsCastPrimitiveName' :: Class -> Class -> String
toHsCastPrimitiveName' Class
from Class
to =
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"cast", Constness -> Class -> String
toHsDataTypeName' Constness
Nonconst Class
from, String
"To", Constness -> Class -> String
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 String
toHsConstCastFnName Constness
cst Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsConstCastFnName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsConstCastFnName' Constness
cst Class
cls

-- | Pure version of 'toHsConstCastFnName' that doesn't create a qualified name.
toHsConstCastFnName' :: Constness -> Class -> String
toHsConstCastFnName' :: Constness -> Class -> String
toHsConstCastFnName' Constness
cst Class
cls =
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"cast", Constness -> Class -> String
toHsDataTypeName' Constness
Nonconst Class
cls,
          case Constness
cst of
            Constness
Const -> String
"ToConst"
            Constness
Nonconst -> String
"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 String
toHsDataTypeName Constness
cst Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsDataTypeName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Constness -> Class -> String
toHsDataTypeName' Constness
cst Class
cls

-- | Pure version of 'toHsDataTypeName' that doesn't create a qualified name.
toHsDataTypeName' :: Constness -> Class -> String
toHsDataTypeName' :: Constness -> Class -> String
toHsDataTypeName' Constness
cst Class
cls = Constness -> ExtName -> String
LH.toHsTypeName' Constness
cst (ExtName -> String) -> ExtName -> String
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 String
toHsDataCtorName Managed
m Constness
cst Class
cls =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsDataCtorName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Managed -> Constness -> Class -> String
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 -> String
toHsDataCtorName' Managed
m Constness
cst Class
cls = case Managed
m of
  Managed
LH.Unmanaged -> String
base
  Managed
LH.Managed -> String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Gc"
  where base :: String
base = Constness -> Class -> String
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 -> String
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 -> String
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 -> String
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 -> String
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 String
toHsCtorName Class
cls Ctor
ctor =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsCtorName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  Class -> String -> Generator String
forall name.
IsFnName String name =>
Class -> name -> Generator String
toHsClassEntityName Class
cls (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
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 -> String
toHsCtorName' Class
cls Ctor
ctor =
  Class -> ShowS
forall name. IsFnName String name => Class -> name -> String
toHsClassEntityName' Class
cls ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
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 String
toHsMethodName Class
cls Method
method =
  String -> Generator String -> Generator String
forall a. String -> Generator a -> Generator a
LH.inFunction String
"toHsMethodName" (Generator String -> Generator String)
-> Generator String -> Generator String
forall a b. (a -> b) -> a -> b
$
  Class -> String -> Generator String
forall name.
IsFnName String name =>
Class -> name -> Generator String
toHsClassEntityName Class
cls (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
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 -> String
toHsMethodName' Class
cls Method
method =
  Class -> ShowS
forall name. IsFnName String name => Class -> name -> String
toHsClassEntityName' Class
cls ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
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 :: Class -> name -> Generator String
toHsClassEntityName Class
cls name
name =
  ExtName -> String -> Generator String
LH.addExtNameModule (Class -> ExtName
classExtName Class
cls) (String -> Generator String) -> String -> Generator String
forall a b. (a -> b) -> a -> b
$ Class -> name -> String
forall name. IsFnName String name => Class -> name -> String
toHsClassEntityName' Class
cls name
name

-- | Pure version of 'toHsClassEntityName' that doesn't create a qualified name.
toHsClassEntityName' :: IsFnName String name => Class -> name -> String
toHsClassEntityName' :: Class -> name -> String
toHsClassEntityName' Class
cls name
name =
  ShowS
lowerFirst ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ExtName -> String
fromExtName (ExtName -> String) -> ExtName -> String
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 String
forall t a. IsFnName t a => a -> FnName t
toFnName name
name of
    FnName String
name' -> HasCallStack => String -> ExtName
String -> ExtName
toExtName String
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 (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 (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