module Foreign.Hoppy.Generator.Spec.Class (
Class,
makeClass,
classExtName,
classIdentifier,
classReqs,
classAddendum,
classSuperclasses,
classIsMonomorphicSuperclass, classSetMonomorphicSuperclass,
classIsSubclassOfMonomorphic, classSetSubclassOfMonomorphic,
classEntities, classAddEntities, classVariables, classCtors, classMethods,
classEntityPrefix, classSetEntityPrefix,
classDtorIsPublic, classSetDtorPrivate,
classConversion,
classIsException, classMakeException,
ClassEntity (..), IsClassEntity (..),
classEntityExtName, classEntityExtNames,
classEntityForeignName, classEntityForeignName',
ClassVariable,
makeClassVariable, makeClassVariable_,
mkClassVariable, mkClassVariable_,
mkStaticClassVariable,
mkStaticClassVariable_,
Ctor,
makeCtor, makeCtor_,
mkCtor, mkCtor_,
ctorExtName,
ctorParams,
ctorExceptionHandlers,
Method, MethodApplicability (..), Staticness (..), MethodImpl (..),
makeMethod, makeMethod_,
makeFnMethod, makeFnMethod_,
mkMethod, mkMethod_, mkMethod', mkMethod'_,
mkConstMethod, mkConstMethod_, mkConstMethod', mkConstMethod'_,
mkStaticMethod, mkStaticMethod_, mkStaticMethod', mkStaticMethod'_,
methodExtName, methodImpl, methodApplicability, methodConst, methodStatic, methodPurity,
methodParams, methodReturn, methodExceptionHandlers,
Prop,
mkProp, mkProp_,
mkStaticProp, mkStaticProp_,
mkBoolIsProp, mkBoolIsProp_,
mkBoolHasProp, mkBoolHasProp_,
ClassConversion (..), classConversionNone, classModifyConversion, classSetConversion,
ClassHaskellConversion (..), classSetHaskellConversion,
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',
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),
)
data Class = Class
{ Class -> ExtName
classExtName :: ExtName
, Class -> Identifier
classIdentifier :: Identifier
, Class -> [Class]
classSuperclasses :: [Class]
, Class -> [ClassEntity]
classEntities :: [ClassEntity]
, Class -> Bool
classDtorIsPublic :: Bool
, Class -> ClassConversion
classConversion :: ClassConversion
, Class -> Reqs
classReqs :: Reqs
, Class -> Addendum
classAddendum :: Addendum
, Class -> Bool
classIsMonomorphicSuperclass :: Bool
, Class -> Bool
classIsSubclassOfMonomorphic :: Bool
, Class -> Bool
classIsException :: Bool
, Class -> String
classEntityPrefix :: String
}
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 }
makeClass :: Identifier
-> Maybe ExtName
-> [Class]
-> [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
"_"
}
classSetEntityPrefix :: String -> Class -> Class
classSetEntityPrefix :: String -> Class -> Class
classSetEntityPrefix String
prefix Class
cls = Class
cls { classEntityPrefix :: String
classEntityPrefix = String
prefix }
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 }
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
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
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
classSetDtorPrivate :: Class -> Class
classSetDtorPrivate :: Class -> Class
classSetDtorPrivate Class
cls = Class
cls { classDtorIsPublic :: Bool
classDtorIsPublic = Bool
False }
classSetMonomorphicSuperclass :: Class -> Class
classSetMonomorphicSuperclass :: Class -> Class
classSetMonomorphicSuperclass Class
cls = Class
cls { classIsMonomorphicSuperclass :: Bool
classIsMonomorphicSuperclass = Bool
True }
classSetSubclassOfMonomorphic :: Class -> Class
classSetSubclassOfMonomorphic :: Class -> Class
classSetSubclassOfMonomorphic Class
cls = Class
cls { classIsSubclassOfMonomorphic :: Bool
classIsSubclassOfMonomorphic = Bool
True }
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
data ClassConversion = ClassConversion
{ ClassConversion -> ClassHaskellConversion
classHaskellConversion :: ClassHaskellConversion
}
classConversionNone :: ClassConversion
classConversionNone :: ClassConversion
classConversionNone = ClassHaskellConversion -> ClassConversion
ClassConversion ClassHaskellConversion
classHaskellConversionNone
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'
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
data ClassHaskellConversion = ClassHaskellConversion
{ ClassHaskellConversion -> Maybe (Generator HsType)
classHaskellConversionType :: Maybe (LH.Generator HsType)
, ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionToCppFn :: Maybe (LH.Generator ())
, ClassHaskellConversion -> Maybe (Generator ())
classHaskellConversionFromCppFn :: Maybe (LH.Generator ())
}
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
}
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 }
class IsClassEntity a where
classEntityExtNameSuffix :: a -> ExtName
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)
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
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
data ClassEntity =
CEVar ClassVariable
| CECtor Ctor
| CEMethod Method
| CEProp Prop
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
data ClassVariable = ClassVariable
{ ClassVariable -> ExtName
classVarExtName :: ExtName
, ClassVariable -> String
classVarCName :: String
, ClassVariable -> Type
classVarType :: Type
, ClassVariable -> Staticness
classVarStatic :: Staticness
, ClassVariable -> Bool
classVarGettable :: Bool
}
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
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
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
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_
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
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_
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
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"
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"
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"
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"
data Ctor = Ctor
{ Ctor -> ExtName
ctorExtName :: ExtName
, Ctor -> [Parameter]
ctorParams :: [Parameter]
, Ctor -> ExceptionHandlers
ctorExceptionHandlers :: ExceptionHandlers
}
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
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_
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 :: 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_
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)
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
data Method = Method
{ Method -> MethodImpl
methodImpl :: MethodImpl
, Method -> ExtName
methodExtName :: ExtName
, Method -> MethodApplicability
methodApplicability :: MethodApplicability
, Method -> Purity
methodPurity :: Purity
, Method -> [Parameter]
methodParams :: [Parameter]
, Method -> Type
methodReturn :: Type
, Method -> ExceptionHandlers
methodExceptionHandlers :: ExceptionHandlers
}
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
data MethodImpl =
RealMethod (FnName String)
| FnMethod (FnName Identifier)
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)
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)
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)
methodConst :: Method -> Constness
methodConst :: Method -> Constness
methodConst Method
method = case Method -> MethodApplicability
methodApplicability Method
method of
MethodApplicability
MConst -> Constness
Const
MethodApplicability
_ -> Constness
Nonconst
methodStatic :: Method -> Staticness
methodStatic :: Method -> Staticness
methodStatic Method
method = case Method -> MethodApplicability
methodApplicability Method
method of
MethodApplicability
MStatic -> Staticness
Static
MethodApplicability
_ -> Staticness
Nonstatic
makeMethod :: (IsFnName String name, IsParameter p)
=> name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> 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_
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
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_
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
makeMethod' :: (IsFnName String name, IsParameter p)
=> name
-> MethodApplicability
-> Purity
-> [p]
-> 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
makeMethod'' :: (IsFnName String name, IsParameter p)
=> name
-> String
-> MethodApplicability
-> Purity
-> [p]
-> 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
makeMethod''' :: (HasCallStack, IsParameter p)
=> FnName String
-> Maybe String
-> MethodApplicability
-> Purity
-> [p]
-> 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
mkMethod :: (IsFnName String name, IsParameter p)
=> name
-> [p]
-> 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_
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
mkMethod' :: (IsFnName String name, IsParameter p)
=> name
-> String
-> [p]
-> 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'_
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
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_
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
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'_
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
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_
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
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'_
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
newtype Prop = Prop [Method]
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_
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
]
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_
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
]
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_
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
]
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_
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
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
[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
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"
[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
[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
[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
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]
cppDeleteFnPrefix :: String
cppDeleteFnPrefix :: String
cppDeleteFnPrefix = String
"gendel"
cppDeleteFnName :: Class -> String
cppDeleteFnName :: Class -> String
cppDeleteFnName = String -> Class -> String
makeClassCppName String
cppDeleteFnPrefix
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
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
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"]
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]
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 ()
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]
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]
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)"]
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'"]
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
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') = ",
String
"if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ",
String
"(HoppyP.flip ", String
hsCtorGc, String
" ptr') $ ",
String
"HoppyF.newForeignPtr ",
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]
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
[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
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
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 ())"]
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 ()
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 ()"]
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
[String] -> Generator ()
LH.saysLn [String
"instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", String
typeName, String
")) ",
String
typeName]
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
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
")"]
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
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
")"]
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
")"]
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
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'"]
[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 ",
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) ->
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
")"]
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"]
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 ->
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"]
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
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
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"
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
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"]
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
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"
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
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
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
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
""]
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
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
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
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]
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
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"]
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
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
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
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
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
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
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
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
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
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
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
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
sayCppExportVar ::
Type
-> Maybe (Type, Type)
-> Bool
-> ExtName
-> ExtName
-> LC.Generator ()
-> 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')
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
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
sayHsExportVar ::
LH.SayExportMode
-> Type
-> Maybe Class
-> Bool
-> ExtName
-> ExtName
-> ExtName
-> ExtName
-> 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