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
{ classExtName :: ExtName
, classIdentifier :: Identifier
, classSuperclasses :: [Class]
, classEntities :: [ClassEntity]
, classDtorIsPublic :: Bool
, classConversion :: ClassConversion
, classReqs :: Reqs
, classAddendum :: Addendum
, classIsMonomorphicSuperclass :: Bool
, classIsSubclassOfMonomorphic :: Bool
, classIsException :: Bool
, classEntityPrefix :: String
}
instance Eq Class where
(==) = (==) `on` classExtName
instance Ord Class where
compare = compare `on` classExtName
instance Show Class where
show cls =
concat ["<Class ", show (classExtName cls), " ", show (classIdentifier cls), ">"]
instance Exportable Class where
sayExportCpp = sayCppExport
sayExportHaskell = sayHsExport
getExportExceptionClass cls =
if classIsException cls
then Just cls
else Nothing
instance HasExtNames Class where
getPrimaryExtName = classExtName
getNestedExtNames cls = concatMap (classEntityExtNames cls) $ classEntities cls
instance HasReqs Class where
getReqs = classReqs
setReqs reqs cls = cls { classReqs = reqs }
instance HasAddendum Class where
getAddendum = classAddendum
setAddendum addendum cls = cls { classAddendum = addendum }
makeClass :: Identifier
-> Maybe ExtName
-> [Class]
-> [ClassEntity]
-> Class
makeClass identifier maybeExtName supers entities =
let extName = extNameOrIdentifier identifier maybeExtName
in Class
{ classIdentifier = identifier
, classExtName = extName
, classSuperclasses = supers
, classEntities = entities
, classDtorIsPublic = True
, classConversion = classConversionNone
, classReqs = mempty
, classAddendum = mempty
, classIsMonomorphicSuperclass = False
, classIsSubclassOfMonomorphic = False
, classIsException = False
, classEntityPrefix = fromExtName extName ++ "_"
}
classSetEntityPrefix :: String -> Class -> Class
classSetEntityPrefix prefix cls = cls { classEntityPrefix = prefix }
classAddEntities :: [ClassEntity] -> Class -> Class
classAddEntities ents cls =
if null ents then cls else cls { classEntities = classEntities cls ++ ents }
classVariables :: Class -> [ClassVariable]
classVariables = mapMaybe pickVar . classEntities
where pickVar ent = case ent of
CEVar v -> Just v
CECtor _ -> Nothing
CEMethod _ -> Nothing
CEProp _ -> Nothing
classCtors :: Class -> [Ctor]
classCtors = mapMaybe pickCtor . classEntities
where pickCtor ent = case ent of
CEVar _ -> Nothing
CECtor ctor -> Just ctor
CEMethod _ -> Nothing
CEProp _ -> Nothing
classMethods :: Class -> [Method]
classMethods = concatMap pickMethods . classEntities
where pickMethods ent = case ent of
CEVar _ -> []
CECtor _ -> []
CEMethod m -> [m]
CEProp (Prop ms) -> ms
classSetDtorPrivate :: Class -> Class
classSetDtorPrivate cls = cls { classDtorIsPublic = False }
classSetMonomorphicSuperclass :: Class -> Class
classSetMonomorphicSuperclass cls = cls { classIsMonomorphicSuperclass = True }
classSetSubclassOfMonomorphic :: Class -> Class
classSetSubclassOfMonomorphic cls = cls { classIsSubclassOfMonomorphic = True }
classMakeException :: Class -> Class
classMakeException cls = case classIsException cls of
False -> cls { classIsException = True }
True -> cls
data ClassConversion = ClassConversion
{ classHaskellConversion :: ClassHaskellConversion
}
classConversionNone :: ClassConversion
classConversionNone = ClassConversion classHaskellConversionNone
classModifyConversion :: HasCallStack => (ClassConversion -> ClassConversion) -> Class -> Class
classModifyConversion f cls =
let cls' = cls { classConversion = f $ classConversion cls }
conv = classConversion cls'
haskellConv = classHaskellConversion conv
in case undefined of
_ | (isJust (classHaskellConversionToCppFn haskellConv) ||
isJust (classHaskellConversionFromCppFn haskellConv)) &&
isNothing (classHaskellConversionType haskellConv) ->
error $ "classModifyConversion: " ++ show cls' ++
" was given a Haskell-to-C++ or C++-to-Haskell conversion function" ++
" but no Haskell type. Please provide a classHaskellConversionType."
_ -> cls'
classSetConversion :: ClassConversion -> Class -> Class
classSetConversion c = classModifyConversion $ const c
data ClassHaskellConversion = ClassHaskellConversion
{ classHaskellConversionType :: Maybe (LH.Generator HsType)
, classHaskellConversionToCppFn :: Maybe (LH.Generator ())
, classHaskellConversionFromCppFn :: Maybe (LH.Generator ())
}
classHaskellConversionNone :: ClassHaskellConversion
classHaskellConversionNone =
ClassHaskellConversion
{ classHaskellConversionType = Nothing
, classHaskellConversionToCppFn = Nothing
, classHaskellConversionFromCppFn = Nothing
}
classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class
classSetHaskellConversion conv = classModifyConversion $ \c ->
c { classHaskellConversion = conv }
class IsClassEntity a where
classEntityExtNameSuffix :: a -> ExtName
classEntityExtName :: IsClassEntity a => Class -> a -> ExtName
classEntityExtName cls x =
toExtName $ fromExtName (classExtName cls) ++ "_" ++ fromExtName (classEntityExtNameSuffix x)
classEntityForeignName :: IsClassEntity a => Class -> a -> ExtName
classEntityForeignName cls x =
classEntityForeignName' cls $ classEntityExtNameSuffix x
classEntityForeignName' :: Class -> ExtName -> ExtName
classEntityForeignName' cls extName =
toExtName $ classEntityPrefix cls ++ fromExtName extName
data ClassEntity =
CEVar ClassVariable
| CECtor Ctor
| CEMethod Method
| CEProp Prop
classEntityExtNames :: Class -> ClassEntity -> [ExtName]
classEntityExtNames cls ent = case ent of
CEVar v -> [classEntityExtName cls v]
CECtor ctor -> [classEntityExtName cls ctor]
CEMethod m -> [classEntityExtName cls m]
CEProp (Prop methods) -> map (classEntityExtName cls) methods
data ClassVariable = ClassVariable
{ classVarExtName :: ExtName
, classVarCName :: String
, classVarType :: Type
, classVarStatic :: Staticness
, classVarGettable :: Bool
}
instance Show ClassVariable where
show v =
concat ["<ClassVariable ",
show $ classVarExtName v, " ",
show $ classVarCName v, " ",
show $ classVarStatic v, " ",
show $ classVarType v, ">"]
instance IsClassEntity ClassVariable where
classEntityExtNameSuffix = classVarExtName
makeClassVariable :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassEntity
makeClassVariable cName maybeExtName tp static gettable =
CEVar $ makeClassVariable_ cName maybeExtName tp static gettable
makeClassVariable_ :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ cName maybeExtName =
ClassVariable (extNameOrString cName maybeExtName) cName
mkClassVariable :: String -> Type -> ClassEntity
mkClassVariable = (CEVar .) . mkClassVariable_
mkClassVariable_ :: String -> Type -> ClassVariable
mkClassVariable_ cName t = makeClassVariable_ cName Nothing t Nonstatic True
mkStaticClassVariable :: String -> Type -> ClassEntity
mkStaticClassVariable = (CEVar .) . mkStaticClassVariable_
mkStaticClassVariable_ :: String -> Type -> ClassVariable
mkStaticClassVariable_ cName t = makeClassVariable_ cName Nothing t Static True
classVarGetterExtName :: Class -> ClassVariable -> ExtName
classVarGetterExtName cls v =
toExtName $ fromExtName (classEntityExtName cls v) ++ "_get"
classVarGetterForeignName :: Class -> ClassVariable -> ExtName
classVarGetterForeignName cls v =
toExtName $ fromExtName (classEntityForeignName cls v) ++ "_get"
classVarSetterExtName :: Class -> ClassVariable -> ExtName
classVarSetterExtName cls v =
toExtName $ fromExtName (classEntityExtName cls v) ++ "_set"
classVarSetterForeignName :: Class -> ClassVariable -> ExtName
classVarSetterForeignName cls v =
toExtName $ fromExtName (classEntityForeignName cls v) ++ "_set"
data Ctor = Ctor
{ ctorExtName :: ExtName
, ctorParams :: [Parameter]
, ctorExceptionHandlers :: ExceptionHandlers
}
instance Show Ctor where
show ctor = concat ["<Ctor ", show (ctorExtName ctor), " ", show (ctorParams ctor), ">"]
instance HandlesExceptions Ctor where
getExceptionHandlers = ctorExceptionHandlers
modifyExceptionHandlers f ctor = ctor { ctorExceptionHandlers = f $ ctorExceptionHandlers ctor }
instance IsClassEntity Ctor where
classEntityExtNameSuffix = ctorExtName
makeCtor :: IsParameter p => ExtName -> [p] -> ClassEntity
makeCtor = (CECtor .) . makeCtor_
makeCtor_ :: IsParameter p => ExtName -> [p] -> Ctor
makeCtor_ extName params = Ctor extName (map toParameter params) mempty
mkCtor :: IsParameter p => String -> [p] -> ClassEntity
mkCtor = (CECtor .) . mkCtor_
mkCtor_ :: IsParameter p => String -> [p] -> Ctor
mkCtor_ extName params = makeCtor_ (toExtName extName) (map toParameter params)
classFindCopyCtor :: Class -> Maybe Ctor
classFindCopyCtor cls = case mapMaybe check $ classCtors cls of
[ctor] -> Just ctor
_ -> Nothing
where check ctor =
let paramTypes = map (stripConst . normalizeType . parameterType) $ ctorParams ctor
in if paramTypes == [Internal_TObj cls] ||
paramTypes == [Internal_TRef $ Internal_TConst $ Internal_TObj cls]
then Just ctor
else Nothing
data Method = Method
{ methodImpl :: MethodImpl
, methodExtName :: ExtName
, methodApplicability :: MethodApplicability
, methodPurity :: Purity
, methodParams :: [Parameter]
, methodReturn :: Type
, methodExceptionHandlers :: ExceptionHandlers
}
instance Show Method where
show method =
concat ["<Method ", show (methodExtName method), " ",
case methodImpl method of
RealMethod name -> show name
FnMethod name -> show name, " ",
show (methodApplicability method), " ",
show (methodPurity method), " ",
show (methodParams method), " ",
show (methodReturn method), ">"]
instance HandlesExceptions Method where
getExceptionHandlers = methodExceptionHandlers
modifyExceptionHandlers f method =
method { methodExceptionHandlers = f $ methodExceptionHandlers method }
instance IsClassEntity Method where
classEntityExtNameSuffix = methodExtName
data MethodImpl =
RealMethod (FnName String)
| FnMethod (FnName Identifier)
deriving (Eq, Show)
data MethodApplicability = MNormal | MStatic | MConst
deriving (Bounded, Enum, Eq, Show)
data Staticness = Nonstatic | Static
deriving (Bounded, Enum, Eq, Show)
methodConst :: Method -> Constness
methodConst method = case methodApplicability method of
MConst -> Const
_ -> Nonconst
methodStatic :: Method -> Staticness
methodStatic method = case methodApplicability method of
MStatic -> Static
_ -> Nonstatic
makeMethod :: (IsFnName String name, IsParameter p)
=> name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
makeMethod = (((((CEMethod .) .) .) .) .) . makeMethod_
makeMethod_ :: (IsFnName String name, IsParameter p)
=> name
-> ExtName
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod_ cName extName appl purity paramTypes retType =
Method (RealMethod $ toFnName cName) extName appl purity
(toParameters paramTypes) retType mempty
makeFnMethod :: (IsFnName Identifier name, IsParameter p)
=> name
-> String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> ClassEntity
makeFnMethod = (((((CEMethod .) .) .) .) .) . makeFnMethod_
makeFnMethod_ :: (IsFnName Identifier name, IsParameter p)
=> name
-> String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeFnMethod_ cName foreignName appl purity paramTypes retType =
Method (FnMethod $ toFnName cName) (toExtName foreignName)
appl purity (toParameters paramTypes) retType mempty
makeMethod' :: (IsFnName String name, IsParameter p)
=> name
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod' name = makeMethod''' (toFnName name) Nothing
makeMethod'' :: (IsFnName String name, IsParameter p)
=> name
-> String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod'' name foreignName = makeMethod''' (toFnName name) $ Just foreignName
makeMethod''' :: (HasCallStack, IsParameter p)
=> FnName String
-> Maybe String
-> MethodApplicability
-> Purity
-> [p]
-> Type
-> Method
makeMethod''' (FnName "") maybeForeignName _ _ paramTypes retType =
error $ concat ["makeMethod''': Given an empty method name with foreign name ",
show maybeForeignName, ", parameter types ", show paramTypes,
", and return type ", show retType, "."]
makeMethod''' name (Just "") _ _ paramTypes retType =
error $ concat ["makeMethod''': Given an empty foreign name with method ",
show name, ", parameter types ", show paramTypes, ", and return type ",
show retType, "."]
makeMethod''' name maybeForeignName appl purity paramTypes retType =
let extName = flip fromMaybe (toExtName <$> maybeForeignName) $ case name of
FnName s -> toExtName s
FnOp op -> operatorPreferredExtName op
in makeMethod_ name extName appl purity (toParameters paramTypes) retType
mkMethod :: (IsFnName String name, IsParameter p)
=> name
-> [p]
-> Type
-> ClassEntity
mkMethod = ((CEMethod .) .) . mkMethod_
mkMethod_ :: (IsFnName String name, IsParameter p)
=> name
-> [p]
-> Type
-> Method
mkMethod_ name = makeMethod' name MNormal Nonpure
mkMethod' :: (IsFnName String name, IsParameter p)
=> name
-> String
-> [p]
-> Type
-> ClassEntity
mkMethod' = (((CEMethod .) .) .) . mkMethod'_
mkMethod'_ :: (IsFnName String name, IsParameter p)
=> name
-> String
-> [p]
-> Type
-> Method
mkMethod'_ cName foreignName = makeMethod'' cName foreignName MNormal Nonpure
mkConstMethod :: (IsFnName String name, IsParameter p)
=> name
-> [p]
-> Type
-> ClassEntity
mkConstMethod = ((CEMethod .) .) . mkConstMethod_
mkConstMethod_ :: (IsFnName String name, IsParameter p)
=> name
-> [p]
-> Type
-> Method
mkConstMethod_ name = makeMethod' name MConst Nonpure
mkConstMethod' :: (IsFnName String name, IsParameter p)
=> name
-> String
-> [p]
-> Type
-> ClassEntity
mkConstMethod' = (((CEMethod .) .) .) . mkConstMethod'_
mkConstMethod'_ :: (IsFnName String name, IsParameter p)
=> name
-> String
-> [p]
-> Type
-> Method
mkConstMethod'_ cName foreignName = makeMethod'' cName foreignName MConst Nonpure
mkStaticMethod :: (IsFnName String name, IsParameter p)
=> name
-> [p]
-> Type
-> ClassEntity
mkStaticMethod = ((CEMethod .) .) . mkStaticMethod_
mkStaticMethod_ :: (IsFnName String name, IsParameter p)
=> name
-> [p]
-> Type
-> Method
mkStaticMethod_ name = makeMethod' name MStatic Nonpure
mkStaticMethod' :: (IsFnName String name, IsParameter p)
=> name
-> String
-> [p]
-> Type
-> ClassEntity
mkStaticMethod' = (((CEMethod .) .) .) . mkStaticMethod'_
mkStaticMethod'_ :: (IsFnName String name, IsParameter p)
=> name
-> String
-> [p]
-> Type
-> Method
mkStaticMethod'_ cName foreignName = makeMethod'' cName foreignName MStatic Nonpure
newtype Prop = Prop [Method]
mkProp :: String -> Type -> ClassEntity
mkProp = (CEProp .) . mkProp_
mkProp_ :: String -> Type -> Prop
mkProp_ name t =
let c:cs = name
setName = 's' : 'e' : 't' : toUpper c : cs
in Prop [ mkConstMethod_ name np t
, mkMethod_ setName [t] Internal_TVoid
]
mkStaticProp :: String -> Type -> ClassEntity
mkStaticProp = (CEProp .) . mkStaticProp_
mkStaticProp_ :: String -> Type -> Prop
mkStaticProp_ name t =
let c:cs = name
setName = 's' : 'e' : 't' : toUpper c : cs
in Prop [ mkStaticMethod_ name np t
, mkStaticMethod_ setName [t] Internal_TVoid
]
mkBoolIsProp :: String -> ClassEntity
mkBoolIsProp = CEProp . mkBoolIsProp_
mkBoolIsProp_ :: String -> Prop
mkBoolIsProp_ name =
let c:cs = name
name' = toUpper c : cs
isName = 'i':'s':name'
setName = 's':'e':'t':name'
in Prop [ mkConstMethod_ isName np boolT
, mkMethod_ setName [boolT] voidT
]
mkBoolHasProp :: String -> ClassEntity
mkBoolHasProp = CEProp . mkBoolHasProp_
mkBoolHasProp_ :: String -> Prop
mkBoolHasProp_ name =
let c:cs = name
name' = toUpper c : cs
hasName = 'h':'a':'s':name'
setName = 's':'e':'t':name'
in Prop [ mkConstMethod_ hasName np boolT
, mkMethod_ setName [boolT] voidT
]
sayCppExport :: LC.SayExportMode -> Class -> LC.Generator ()
sayCppExport mode cls = case mode of
LC.SayHeader -> return ()
LC.SaySource -> do
let clsPtr = ptrT $ objT cls
constClsPtr = ptrT $ constT $ objT cls
LC.addReqsM $ classReqs cls
forM_ (classCtors cls) $ \ctor ->
Function.sayCppExportFn
(classEntityExtName cls ctor)
(Function.CallFn $ LC.say "new" >> LC.sayIdentifier (classIdentifier cls))
Nothing
(ctorParams ctor)
clsPtr
(ctorExceptionHandlers ctor)
True
when (classDtorIsPublic cls) $
LC.sayFunction (cppDeleteFnName cls)
["self"]
(fnT [constClsPtr] voidT) $
Just $ LC.say "delete self;\n"
forM_ (classVariables cls) $ sayCppExportClassVar cls
forM_ (classMethods cls) $ \method -> do
let static = case methodStatic method of
Static -> True
Nonstatic -> False
thisType = case methodConst method of
Const -> constClsPtr
Nonconst -> clsPtr
nonMemberCall = static || case methodImpl method of
RealMethod {} -> False
FnMethod {} -> True
Function.sayCppExportFn
(classEntityExtName cls method)
(case methodImpl method of
RealMethod name -> case name of
FnName cName -> Function.CallFn $ do
when static $ do
LC.sayIdentifier (classIdentifier cls)
LC.say "::"
LC.say cName
FnOp op -> Function.CallOp op
FnMethod name -> case name of
FnName cName -> Function.CallFn $ LC.sayIdentifier cName
FnOp op -> Function.CallOp op)
(if nonMemberCall then Nothing else Just thisType)
(methodParams method)
(methodReturn method)
(methodExceptionHandlers method)
True
forM_ (classSuperclasses cls) $ genUpcastFns cls
unless (classIsSubclassOfMonomorphic cls) $
forM_ (classSuperclasses cls) $ genDowncastFns cls
where genUpcastFns :: Class -> Class -> LC.Generator ()
genUpcastFns cls' ancestorCls = do
LC.sayFunction (cppCastFnName cls' ancestorCls)
["self"]
(fnT [ptrT $ constT $ objT cls'] $ ptrT $ constT $ objT ancestorCls)
(Just $ LC.say "return self;\n")
forM_ (classSuperclasses ancestorCls) $ genUpcastFns cls'
genDowncastFns :: Class -> Class -> LC.Generator ()
genDowncastFns cls' ancestorCls = unless (classIsMonomorphicSuperclass ancestorCls) $ do
let clsPtr = ptrT $ constT $ objT cls'
ancestorPtr = ptrT $ constT $ objT ancestorCls
LC.sayFunction (cppCastFnName ancestorCls cls')
["self"]
(fnT [ancestorPtr] clsPtr) $ Just $ do
LC.say "return dynamic_cast<"
LC.sayType Nothing clsPtr
LC.say ">(self);\n"
forM_ (classSuperclasses ancestorCls) $ genDowncastFns cls'
sayCppExportClassVar :: Class -> ClassVariable -> LC.Generator ()
sayCppExportClassVar cls v =
sayCppExportVar (classVarType v)
(case classVarStatic v of
Nonstatic -> Just (ptrT $ constT $ objT cls, ptrT $ objT cls)
Static -> Nothing)
(classVarGettable v)
(classVarGetterExtName cls v)
(classVarSetterExtName cls v)
(case classVarStatic v of
Nonstatic -> LC.say $ classVarCName v
Static -> do LC.sayIdentifier $ classIdentifier cls
LC.says ["::", classVarCName v])
makeClassCppName :: String -> Class -> String
makeClassCppName prefix cls = LC.makeCppName [prefix, fromExtName $ classExtName cls]
cppDeleteFnPrefix :: String
cppDeleteFnPrefix = "gendel"
cppDeleteFnName :: Class -> String
cppDeleteFnName = makeClassCppName cppDeleteFnPrefix
cppCastFnName :: Class -> Class -> String
cppCastFnName from to =
concat [ "gencast__"
, fromExtName $ classExtName from
, "__"
, fromExtName $ classExtName to
]
sayHsExport :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExport mode cls = LH.withErrorContext ("generating class " ++ show (classExtName cls)) $ do
case mode of
LH.SayExportForeignImports -> do
sayHsExportClassVars mode cls
sayHsExportClassCtors mode cls
forM_ (classMethods cls) $ \method ->
(Function.sayHsExportFn mode <$> classEntityExtName cls <*> classEntityForeignName cls <*>
methodPurity <*> pure (getMethodEffectiveParams cls method) <*>
methodReturn <*> methodExceptionHandlers)
method
LH.SayExportDecls -> do
sayHsExportClassClass True cls Const
sayHsExportClassClass True cls Nonconst
sayHsExportClassStaticMethods cls
sayHsExportClassDataType True cls Const
sayHsExportClassDataType True cls Nonconst
sayHsExportClassExceptionSupport True cls
sayHsExportClassVars mode cls
sayHsExportClassCtors mode cls
LH.SayExportBoot -> do
sayHsExportClassClass False cls Const
sayHsExportClassClass False cls Nonconst
sayHsExportClassDataType False cls Const
sayHsExportClassDataType False cls Nonconst
sayHsExportClassExceptionSupport False cls
sayHsExportClassVars mode cls
sayHsExportClassCastPrimitives mode cls
sayHsExportClassSpecialFns mode cls
sayHsExportClassClass :: Bool -> Class -> Constness -> LH.Generator ()
sayHsExportClassClass doDecls cls cst = LH.withErrorContext "generating Haskell typeclass" $ do
hsTypeName <- toHsDataTypeName cst cls
hsValueClassName <- toHsValueClassName cls
hsWithValuePtrName <- toHsWithValuePtrName cls
hsPtrClassName <- toHsPtrClassName cst cls
hsCastMethodName <- toHsCastMethodName cst cls
let supers = classSuperclasses cls
hsSupers <-
(\x -> if null x
then do LH.addImports hsImportForRuntime
return ["HoppyFHR.CppPtr"]
else return x) =<<
case cst of
Const -> mapM (toHsPtrClassName Const) supers
Nonconst ->
(:) <$> toHsPtrClassName Const cls <*> mapM (toHsPtrClassName Nonconst) supers
when (cst == Const) $ do
LH.addImports hsImportForPrelude
LH.addExport' hsValueClassName
LH.ln
LH.saysLn ["class ", hsValueClassName, " a where"]
LH.indent $
LH.saysLn [hsWithValuePtrName, " :: a -> (", hsTypeName, " -> HoppyP.IO b) -> HoppyP.IO b"]
LH.ln
LH.saysLn ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a",
if doDecls then " where" else ""]
when doDecls $ do
LH.addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"],
hsImportForPrelude]
LH.indent $ LH.saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName]
let conv = LH.getClassHaskellConversion cls
case (classHaskellConversionType conv,
classHaskellConversionToCppFn conv) of
(Just hsTypeGen, Just _) -> do
hsType <- hsTypeGen
LH.ln
LH.saysLn ["instance {-# OVERLAPPING #-} ", hsValueClassName,
" (", LH.prettyPrint hsType, ")", if doDecls then " where" else ""]
when doDecls $ do
LH.addImports hsImportForRuntime
LH.indent $ LH.saysLn [hsWithValuePtrName, " = HoppyFHR.withCppObj"]
_ -> return ()
LH.addExport' hsPtrClassName
LH.ln
LH.saysLn $
"class (" :
intersperse ", " (map (++ " this") hsSupers) ++
[") => ", hsPtrClassName, " this where"]
LH.indent $ LH.saysLn [hsCastMethodName, " :: this -> ", hsTypeName]
when doDecls $ do
let methods = filter ((cst ==) . methodConst) $ classMethods cls
forM_ methods $ \method ->
when (methodStatic method == Nonstatic) $
(Function.sayHsExportFn LH.SayExportDecls <$>
classEntityExtName cls <*> classEntityForeignName cls <*>
methodPurity <*> pure (getMethodEffectiveParams cls method) <*>
methodReturn <*> methodExceptionHandlers) method
sayHsExportClassStaticMethods :: Class -> LH.Generator ()
sayHsExportClassStaticMethods cls =
forM_ (classMethods cls) $ \method ->
when (methodStatic method == Static) $
(Function.sayHsExportFn LH.SayExportDecls <$>
classEntityExtName cls <*> classEntityForeignName cls <*>
methodPurity <*> methodParams <*> methodReturn <*> methodExceptionHandlers) method
sayHsExportClassDataType :: Bool -> Class -> Constness -> LH.Generator ()
sayHsExportClassDataType doDecls cls cst = LH.withErrorContext "generating Haskell data types" $ do
hsTypeName <- toHsDataTypeName cst cls
hsCtor <- toHsDataCtorName LH.Unmanaged cst cls
hsCtorGc <- toHsDataCtorName LH.Managed cst cls
constCastFnName <- toHsConstCastFnName cst cls
LH.addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]
LH.addExport' hsTypeName
LH.ln
LH.saysLn ["data ", hsTypeName, " ="]
LH.indent $ do
LH.saysLn [" ", hsCtor, " (HoppyF.Ptr ", hsTypeName, ")"]
LH.saysLn ["| ", hsCtorGc, " (HoppyF.ForeignPtr ()) (HoppyF.Ptr ", hsTypeName, ")"]
when doDecls $ do
LH.addImports $ hsImport1 "Prelude" "(==)"
LH.indent $ LH.sayLn "deriving (HoppyP.Show)"
LH.ln
LH.saysLn ["instance HoppyP.Eq ", hsTypeName, " where"]
LH.indent $ LH.saysLn ["x == y = HoppyFHR.toPtr x == HoppyFHR.toPtr y"]
LH.ln
LH.saysLn ["instance HoppyP.Ord ", hsTypeName, " where"]
LH.indent $ LH.saysLn ["compare x y = HoppyP.compare (HoppyFHR.toPtr x) (HoppyFHR.toPtr y)"]
hsTypeNameOppConst <- toHsDataTypeName (constNegate cst) cls
LH.ln
LH.addExport constCastFnName
LH.saysLn [constCastFnName, " :: ", hsTypeNameOppConst, " -> ", hsTypeName]
when doDecls $ do
LH.addImports $ hsImport1 "Prelude" "($)"
hsCtorOppConst <- toHsDataCtorName LH.Unmanaged (constNegate cst) cls
hsCtorGcOppConst <- toHsDataCtorName LH.Managed (constNegate cst) cls
LH.saysLn [constCastFnName, " (", hsCtorOppConst,
" ptr') = ", hsCtor, " $ HoppyF.castPtr ptr'"]
LH.saysLn [constCastFnName, " (", hsCtorGcOppConst,
" fptr' ptr') = ", hsCtorGc, " fptr' $ HoppyF.castPtr ptr'"]
LH.ln
if doDecls
then do LH.addImports $ hsImport1 "Prelude" "($)"
LH.saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"]
LH.indent $ do
LH.saysLn ["nullptr = ", hsCtor, " HoppyF.nullPtr"]
LH.ln
LH.saysLn ["withCppPtr (", hsCtor, " ptr') f' = f' ptr'"]
LH.saysLn ["withCppPtr (", hsCtorGc,
" fptr' ptr') f' = HoppyF.withForeignPtr fptr' $ \\_ -> f' ptr'"]
LH.ln
LH.saysLn ["toPtr (", hsCtor, " ptr') = ptr'"]
LH.saysLn ["toPtr (", hsCtorGc, " _ ptr') = ptr'"]
LH.ln
LH.saysLn ["touchCppPtr (", hsCtor, " _) = HoppyP.return ()"]
LH.saysLn ["touchCppPtr (", hsCtorGc, " fptr' _) = HoppyF.touchForeignPtr fptr'"]
when (classDtorIsPublic cls) $ do
LH.addImports $ hsImport1 "Prelude" "(==)"
LH.ln
LH.saysLn ["instance HoppyFHR.Deletable ", hsTypeName, " where"]
LH.indent $ do
case cst of
Const ->
LH.saysLn ["delete (", hsCtor, " ptr') = ", toHsClassDeleteFnName' cls, " ptr'"]
Nonconst -> do
constTypeName <- toHsDataTypeName Const cls
LH.saysLn ["delete (",hsCtor, " ptr') = ", toHsClassDeleteFnName' cls,
" $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ", constTypeName, ")"]
LH.saysLn ["delete (", hsCtorGc,
" _ _) = HoppyP.fail $ HoppyP.concat ",
"[\"Deletable.delete: Asked to delete a GC-managed \", ",
show hsTypeName, ", \" object.\"]"]
LH.ln
LH.saysLn ["toGc this'@(", hsCtor, " ptr') = ",
"if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ",
"(HoppyP.flip ", hsCtorGc, " ptr') $ ",
"HoppyF.newForeignPtr ",
"(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls,
" :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",
"(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"]
LH.saysLn ["toGc this'@(", hsCtorGc, " {}) = HoppyP.return this'"]
forM_ (classFindCopyCtor cls) $ \copyCtor -> do
copyCtorName <- toHsCtorName cls copyCtor
LH.ln
LH.saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ",
case cst of
Nonconst -> hsTypeName
Const -> hsTypeNameOppConst,
" where copy = ", copyCtorName]
else do LH.saysLn ["instance HoppyFHR.CppPtr ", hsTypeName]
when (classDtorIsPublic cls) $
LH.saysLn ["instance HoppyFHR.Deletable ", hsTypeName]
forM_ (classFindCopyCtor cls) $ \_ ->
LH.saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ",
case cst of
Nonconst -> hsTypeName
Const -> hsTypeNameOppConst]
genInstances hsTypeName [] cls
where genInstances :: String -> [Class] -> Class -> LH.Generator ()
genInstances hsTypeName path ancestorCls = do
forM_ (case cst of
Const -> [Const]
Nonconst -> [Const, Nonconst]) $ \ancestorCst -> do
LH.ln
ancestorPtrClassName <- toHsPtrClassName ancestorCst ancestorCls
LH.saysLn ["instance ", ancestorPtrClassName, " ", hsTypeName,
if doDecls then " where" else ""]
when doDecls $ LH.indent $ do
let castMethodName = toHsCastMethodName' ancestorCst ancestorCls
if null path && cst == ancestorCst
then do LH.addImports hsImportForPrelude
LH.saysLn [castMethodName, " = HoppyP.id"]
else do let addConst = cst == Nonconst
removeConst = ancestorCst == Nonconst
when (addConst || removeConst) $
LH.addImports hsImportForForeign
forM_ ([minBound..] :: [LH.Managed]) $ \managed -> do
ancestorCtor <- case managed of
LH.Unmanaged -> (\x -> [x]) <$>
toHsDataCtorName LH.Unmanaged ancestorCst ancestorCls
LH.Managed -> (\x -> [x, " fptr'"]) <$>
toHsDataCtorName LH.Managed ancestorCst ancestorCls
ptrPattern <- case managed of
LH.Unmanaged -> (\x -> [x, " ptr'"]) <$>
toHsDataCtorName LH.Unmanaged cst cls
LH.Managed -> (\x -> [x, " fptr' ptr'"]) <$>
toHsDataCtorName LH.Managed cst cls
LH.saysLn . concat =<< sequence
[ return $
[castMethodName, " ("] ++ ptrPattern ++ [") = "] ++ ancestorCtor
, if removeConst
then do ancestorConstType <- toHsDataTypeName Const ancestorCls
ancestorNonconstType <- toHsDataTypeName Nonconst ancestorCls
return [" $ (HoppyF.castPtr :: HoppyF.Ptr ",
ancestorConstType, " -> HoppyF.Ptr ",
ancestorNonconstType, ")"]
else return []
, if not $ null path
then do LH.addImports $ hsImport1 "Prelude" "($)"
castPrimitiveName <- toHsCastPrimitiveName cls cls ancestorCls
return [" $ ", castPrimitiveName]
else return []
, if addConst
then do LH.addImports $ hsImport1 "Prelude" "($)"
nonconstTypeName <- toHsDataTypeName Nonconst cls
constTypeName <- toHsDataTypeName Const cls
return [" $ (HoppyF.castPtr :: HoppyF.Ptr ",
nonconstTypeName, " -> HoppyF.Ptr ",
constTypeName, ")"]
else return []
, return [" ptr'"]
]
forM_ (classSuperclasses ancestorCls) $
genInstances hsTypeName $
ancestorCls : path
sayHsExportClassVars :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassVars mode cls =
forM_ (classVariables cls) $ sayHsExportClassVar mode cls
sayHsExportClassVar :: LH.SayExportMode -> Class -> ClassVariable -> LH.Generator ()
sayHsExportClassVar mode cls v =
LH.withErrorContext ("generating variable " ++ show (classVarExtName v)) $
sayHsExportVar mode
(classVarType v)
(case classVarStatic v of
Nonstatic -> Just cls
Static -> Nothing)
(classVarGettable v)
(classVarGetterExtName cls v)
(classVarGetterForeignName cls v)
(classVarSetterExtName cls v)
(classVarSetterForeignName cls v)
sayHsExportClassCtors :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassCtors mode cls =
LH.withErrorContext "generating constructors" $
forM_ (classCtors cls) $ \ctor ->
(Function.sayHsExportFn mode <$>
classEntityExtName cls <*> classEntityForeignName cls <*>
pure Nonpure <*> ctorParams <*> pure (ptrT $ objT cls) <*>
ctorExceptionHandlers) ctor
sayHsExportClassSpecialFns :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassSpecialFns mode cls = do
typeName <- toHsDataTypeName Nonconst cls
typeNameConst <- toHsDataTypeName Const cls
LH.withErrorContext "generating delete bindings" $
case mode of
LH.SayExportForeignImports -> when (classDtorIsPublic cls) $ do
LH.addImports $ mconcat [hsImportForForeign, hsImportForPrelude]
LH.saysLn ["foreign import ccall \"", cppDeleteFnName cls, "\" ",
toHsClassDeleteFnName' cls, " :: HoppyF.Ptr ",
typeNameConst, " -> HoppyP.IO ()"]
LH.saysLn ["foreign import ccall \"&", cppDeleteFnName cls, "\" ",
toHsClassDeleteFnPtrName' cls, " :: HoppyF.FunPtr (HoppyF.Ptr ",
typeNameConst, " -> HoppyP.IO ())"]
LH.SayExportDecls -> return ()
LH.SayExportBoot -> return ()
LH.withErrorContext "generating pointer Assignable instance" $
case mode of
LH.SayExportForeignImports -> return ()
LH.SayExportDecls -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForForeign,
hsImportForRuntime]
LH.ln
LH.saysLn ["instance HoppyFHR.Assignable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ",
typeName, " where"]
LH.indent $ LH.sayLn "assign ptr' value' = HoppyF.poke ptr' $ HoppyFHR.toPtr value'"
LH.SayExportBoot -> return ()
LH.withErrorContext "generating Assignable instance" $ do
let assignmentMethods = flip filter (classMethods cls) $ \m ->
let paramTypes = map parameterType $ methodParams m
in methodApplicability m == MNormal &&
(paramTypes == [objT cls] || paramTypes == [refT $ constT $ objT cls]) &&
(case methodImpl m of
RealMethod name -> name == FnOp OpAssign
FnMethod name -> name == FnOp OpAssign)
withAssignmentMethod f = case assignmentMethods of
[] -> return ()
[m] -> f m
_ ->
throwError $ concat
["Can't determine an Assignable instance to generator for ", show cls,
" because it has multiple assignment operators ", show assignmentMethods]
when (mode == LH.SayExportDecls) $ withAssignmentMethod $ \m -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "(>>)", hsImportForPrelude]
valueClassName <- toHsValueClassName cls
assignmentMethodName <- toHsMethodName cls m
LH.ln
LH.saysLn ["instance ", valueClassName, " a => HoppyFHR.Assignable ", typeName, " a where"]
LH.indent $
LH.saysLn ["assign x' y' = ", assignmentMethodName, " x' y' >> HoppyP.return ()"]
LH.withErrorContext "generating pointer Decodable instance" $ do
case mode of
LH.SayExportForeignImports -> return ()
LH.SayExportDecls -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "(.)",
hsImportForForeign,
hsImportForPrelude,
hsImportForRuntime]
LH.ln
LH.saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ",
typeName, ")) ", typeName, " where"]
LH.indent $ do
ctorName <- toHsDataCtorName LH.Unmanaged Nonconst cls
LH.saysLn ["decode = HoppyP.fmap ", ctorName, " . HoppyF.peek"]
LH.SayExportBoot -> do
LH.addImports $ mconcat [hsImportForForeign, hsImportForRuntime]
LH.ln
LH.saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ",
typeName]
LH.withErrorContext "generating Encodable/Decodable instances" $ do
let conv = LH.getClassHaskellConversion cls
forM_ (classHaskellConversionType conv) $ \hsTypeGen -> do
let hsTypeStrGen = hsTypeGen >>= \hsType -> return $ "(" ++ LH.prettyPrint hsType ++ ")"
case mode of
LH.SayExportForeignImports -> return ()
LH.SayExportDecls -> do
forM_ (classHaskellConversionToCppFn conv) $ \toCppFnGen -> do
hsTypeStr <- hsTypeStrGen
LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
castMethodName <- toHsCastMethodName Const cls
LH.ln
LH.saysLn ["instance HoppyFHR.Encodable ", typeName, " ", hsTypeStr, " where"]
LH.indent $ do
LH.sayLn "encode ="
LH.indent toCppFnGen
LH.ln
LH.saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " ", hsTypeStr, " where"]
LH.indent $
LH.saysLn ["encode = HoppyP.fmap (", castMethodName,
") . HoppyFHR.encodeAs (HoppyP.undefined :: ", typeName, ")"]
forM_ (classHaskellConversionFromCppFn conv) $ \fromCppFnGen -> do
hsTypeStr <- hsTypeStrGen
LH.addImports hsImportForRuntime
castMethodName <- toHsCastMethodName Const cls
LH.ln
LH.saysLn ["instance HoppyFHR.Decodable ", typeName, " ", hsTypeStr, " where"]
LH.indent $
LH.saysLn ["decode = HoppyFHR.decode . ", castMethodName]
LH.ln
LH.saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " ", hsTypeStr, " where"]
LH.indent $ do
LH.sayLn "decode ="
LH.indent fromCppFnGen
LH.SayExportBoot -> do
forM_ (classHaskellConversionToCppFn conv) $ \_ -> do
hsTypeStr <- hsTypeStrGen
LH.addImports hsImportForRuntime
LH.ln
LH.saysLn ["instance HoppyFHR.Encodable ", typeName, " (", hsTypeStr, ")"]
LH.saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " (", hsTypeStr, ")"]
forM_ (classHaskellConversionFromCppFn conv) $ \_ -> do
hsTypeStr <- hsTypeStrGen
LH.addImports hsImportForRuntime
LH.ln
LH.saysLn ["instance HoppyFHR.Decodable ", typeName, " (", hsTypeStr, ")"]
LH.saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " (", hsTypeStr, ")"]
sayHsExportClassExceptionSupport :: Bool -> Class -> LH.Generator ()
sayHsExportClassExceptionSupport doDecls cls =
when (classIsException cls) $
LH.withErrorContext "generating exception support" $ do
typeName <- toHsDataTypeName Nonconst cls
typeNameConst <- toHsDataTypeName Const cls
exceptionId <- getHsClassExceptionId cls
LH.addImports hsImportForRuntime
LH.ln
LH.saysLn ["instance HoppyFHR.CppException ", typeName,
if doDecls then " where" else ""]
when doDecls $ LH.indent $ do
ctorName <- toHsDataCtorName LH.Unmanaged Nonconst cls
ctorGcName <- toHsDataCtorName LH.Managed Nonconst cls
LH.addImports $ mconcat [hsImports "Prelude" ["($)", "(.)", "(=<<)"],
hsImportForForeign,
hsImportForMap,
hsImportForPrelude]
LH.sayLn "cppExceptionInfo _ ="
LH.indent $ do
LH.saysLn ["HoppyFHR.ExceptionClassInfo (HoppyFHR.ExceptionId ",
show $ getExceptionId exceptionId, ") ", show typeName,
" upcasts' delete' copy' toGc'"]
LH.saysLn ["where delete' ptr' = ", toHsClassDeleteFnName' cls,
" (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeNameConst, ")"]
LH.indentSpaces 6 $ do
LH.ln
LH.saysLn ["copy' = HoppyP.fmap (HoppyF.castPtr . HoppyFHR.toPtr) . HoppyFHR.copy . ",
ctorName, " . HoppyF.castPtr"]
LH.ln
LH.saysLn ["toGc' ptr' = HoppyF.newForeignPtr ",
"(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls,
" :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",
"ptr'"]
LH.sayLn "upcasts' = HoppyDM.fromList"
LH.indent $ case classSuperclasses cls of
[] -> LH.sayLn "[]"
_ -> do
let genCast :: Bool -> [Class] -> Class -> LH.Generator ()
genCast first path ancestorCls =
when (classIsException ancestorCls) $ do
let path' = ancestorCls : path
ancestorId <- getHsClassExceptionId ancestorCls
ancestorCastChain <- forM (zip path' $ drop 1 path') $ \(to, from) ->
toHsCastPrimitiveName from from to
LH.saysLn $ concat [ [if first then "[" else ",",
" ( HoppyFHR.ExceptionId ",
show $ getExceptionId ancestorId,
", \\(e' :: HoppyF.Ptr ()) -> "]
, intersperse " $ " $
"HoppyF.castPtr" :
ancestorCastChain ++
["HoppyF.castPtr e' :: HoppyF.Ptr ()"]
, [")"]
]
forM_ (classSuperclasses ancestorCls) $ genCast False path'
forM_ (zip (classSuperclasses cls) (True : repeat False)) $
\(ancestorCls, first) -> genCast first [cls] ancestorCls
LH.sayLn "]"
LH.ln
LH.saysLn ["cppExceptionBuild fptr' ptr' = ", ctorGcName,
" fptr' (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"]
LH.ln
LH.saysLn ["cppExceptionBuildToGc ptr' = HoppyFHR.toGc $ ", ctorName,
" (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"]
LH.ln
LH.saysLn ["instance HoppyFHR.CppException ", typeNameConst,
if doDecls then " where" else ""]
when doDecls $ LH.indent $ do
LH.addImports $ mconcat [hsImport1 "Prelude" "(.)",
hsImportForPrelude]
constCastFnName <- toHsConstCastFnName Const cls
LH.saysLn ["cppExceptionInfo _ = HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",
typeName, ")"]
LH.saysLn ["cppExceptionBuild = (", constCastFnName,
" .) . HoppyFHR.cppExceptionBuild"]
LH.saysLn ["cppExceptionBuildToGc = HoppyP.fmap ", constCastFnName,
" . HoppyFHR.cppExceptionBuildToGc"]
LH.ln
LH.saysLn ["instance HoppyFHR.CppThrowable ", typeName,
if doDecls then " where" else ""]
when doDecls $ LH.indent $ do
ctorName <- toHsDataCtorName LH.Unmanaged Nonconst cls
ctorGcName <- toHsDataCtorName LH.Managed Nonconst cls
LH.addImports $ mconcat [hsImportForForeign,
hsImportForPrelude]
LH.saysLn ["toSomeCppException this'@(", ctorName, " ptr') = ",
"HoppyFHR.SomeCppException (HoppyFHR.cppExceptionInfo this') HoppyP.Nothing ",
"(HoppyF.castPtr ptr')"]
LH.saysLn ["toSomeCppException this'@(", ctorGcName, " fptr' ptr') = ",
"HoppyFHR.SomeCppException (HoppyFHR.cppExceptionInfo this') (HoppyP.Just fptr') ",
"(HoppyF.castPtr ptr')"]
sayHsExportClassCastPrimitives :: LH.SayExportMode -> Class -> LH.Generator ()
sayHsExportClassCastPrimitives mode cls = LH.withErrorContext "generating cast primitives" $ do
clsType <- toHsDataTypeName Const cls
case mode of
LH.SayExportForeignImports ->
forAncestors cls $ \super -> do
hsCastFnName <- toHsCastPrimitiveName cls cls super
hsDownCastFnName <- toHsCastPrimitiveName cls super cls
superType <- toHsDataTypeName Const super
LH.addImports hsImportForForeign
LH.addExport hsCastFnName
LH.saysLn [ "foreign import ccall \"", cppCastFnName cls super
, "\" ", hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType
]
unless (classIsSubclassOfMonomorphic cls || classIsMonomorphicSuperclass super) $ do
LH.addExport hsDownCastFnName
LH.saysLn [ "foreign import ccall \"", cppCastFnName super cls
, "\" ", hsDownCastFnName, " :: HoppyF.Ptr ", superType, " -> HoppyF.Ptr "
, clsType
]
return True
LH.SayExportDecls ->
unless (classIsSubclassOfMonomorphic cls) $
forM_ [minBound..] $ \cst -> do
downCastClassName <- toHsDownCastClassName cst cls
downCastMethodName <- toHsDownCastMethodName cst cls
typeName <- toHsDataTypeName cst cls
LH.addExport' downCastClassName
LH.ln
LH.saysLn ["class ", downCastClassName, " a where"]
LH.indent $ LH.saysLn [downCastMethodName, " :: ",
LH.prettyPrint $ HsTyFun (HsTyVar $ HsIdent "a") $
HsTyCon $ UnQual $ HsIdent typeName]
LH.ln
forAncestors cls $ \super -> case classIsMonomorphicSuperclass super of
True -> return False
False -> do
superTypeName <- toHsDataTypeName cst super
primitiveCastFn <- toHsCastPrimitiveName cls super cls
LH.saysLn ["instance ", downCastClassName, " ", superTypeName, " where"]
LH.indent $ do
case cst of
Const -> LH.saysLn [downCastMethodName, " = cast'"]
Nonconst -> do
LH.addImports $ hsImport1 "Prelude" "(.)"
castClsToNonconst <- toHsConstCastFnName Nonconst cls
castSuperToConst <- toHsConstCastFnName Const super
LH.saysLn [downCastMethodName, " = ", castClsToNonconst, " . cast' . ",
castSuperToConst]
LH.indent $ do
LH.sayLn "where"
LH.indent $ do
clsCtorName <- toHsDataCtorName LH.Unmanaged Const cls
clsCtorGcName <- toHsDataCtorName LH.Managed Const cls
superCtorName <- toHsDataCtorName LH.Unmanaged Const super
superCtorGcName <- toHsDataCtorName LH.Managed Const super
LH.saysLn ["cast' (", superCtorName, " ptr') = ",
clsCtorName, " $ ", primitiveCastFn, " ptr'"]
LH.saysLn ["cast' (", superCtorGcName, " fptr' ptr') = ",
clsCtorGcName , " fptr' $ ", primitiveCastFn, " ptr'"]
return True
LH.SayExportBoot -> do
forAncestors cls $ \super -> do
hsCastFnName <- toHsCastPrimitiveName cls cls super
superType <- toHsDataTypeName Const super
LH.addImports hsImportForForeign
LH.addExport hsCastFnName
LH.saysLn [hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType]
return True
where forAncestors :: Class -> (Class -> LH.Generator Bool) -> LH.Generator ()
forAncestors cls' f = forM_ (classSuperclasses cls') $ \super -> do
recur <- f super
when recur $ forAncestors super f
getMethodEffectiveParams :: Class -> Method -> [Parameter]
getMethodEffectiveParams cls method =
(case methodImpl method of
RealMethod {} -> case methodApplicability method of
MNormal -> (("this" ~: ptrT $ objT cls) :)
MConst -> (("this" ~: ptrT $ constT $ objT cls) :)
MStatic -> id
FnMethod {} -> id) $
methodParams method
getHsClassExceptionId :: Class -> LH.Generator ExceptionId
getHsClassExceptionId cls = do
iface <- LH.askInterface
fromMaybeM (throwError $ concat
["Internal error, exception class ", show cls, " doesn't have an exception ID"]) $
interfaceExceptionClassId iface cls
toHsValueClassName :: Class -> LH.Generator String
toHsValueClassName cls =
LH.inFunction "toHsValueClassName" $
LH.addExtNameModule (classExtName cls) $ toHsValueClassName' cls
toHsValueClassName' :: Class -> String
toHsValueClassName' cls = toHsDataTypeName' Nonconst cls ++ "Value"
toHsWithValuePtrName :: Class -> LH.Generator String
toHsWithValuePtrName cls =
LH.inFunction "toHsWithValuePtrName" $
LH.addExtNameModule (classExtName cls) $ toHsWithValuePtrName' cls
toHsWithValuePtrName' :: Class -> String
toHsWithValuePtrName' cls = concat ["with", toHsDataTypeName' Nonconst cls, "Ptr"]
toHsPtrClassName :: Constness -> Class -> LH.Generator String
toHsPtrClassName cst cls =
LH.inFunction "toHsPtrClassName" $
LH.addExtNameModule (classExtName cls) $ toHsPtrClassName' cst cls
toHsPtrClassName' :: Constness -> Class -> String
toHsPtrClassName' cst cls = toHsDataTypeName' cst cls ++ "Ptr"
toHsCastMethodName :: Constness -> Class -> LH.Generator String
toHsCastMethodName cst cls =
LH.inFunction "toHsCastMethodName" $
LH.addExtNameModule (classExtName cls) $ toHsCastMethodName' cst cls
toHsCastMethodName' :: Constness -> Class -> String
toHsCastMethodName' cst cls = "to" ++ toHsDataTypeName' cst cls
toHsDownCastClassName :: Constness -> Class -> LH.Generator String
toHsDownCastClassName cst cls =
LH.inFunction "toHsDownCastClassName" $
LH.addExtNameModule (classExtName cls) $ toHsDownCastClassName' cst cls
toHsDownCastClassName' :: Constness -> Class -> String
toHsDownCastClassName' cst cls =
concat [toHsDataTypeName' Nonconst cls,
"Super",
case cst of
Const -> "Const"
Nonconst -> ""]
toHsDownCastMethodName :: Constness -> Class -> LH.Generator String
toHsDownCastMethodName cst cls =
LH.inFunction "toHsDownCastMethodName" $
LH.addExtNameModule (classExtName cls) $ toHsDownCastMethodName' cst cls
toHsDownCastMethodName' :: Constness -> Class -> String
toHsDownCastMethodName' cst cls = "downTo" ++ toHsDataTypeName' cst cls
toHsCastPrimitiveName :: Class -> Class -> Class -> LH.Generator String
toHsCastPrimitiveName descendentClass from to =
LH.inFunction "toHsCastPrimitiveName" $
LH.addExtNameModule (classExtName descendentClass) $ toHsCastPrimitiveName' from to
toHsCastPrimitiveName' :: Class -> Class -> String
toHsCastPrimitiveName' from to =
concat ["cast", toHsDataTypeName' Nonconst from, "To", toHsDataTypeName' Nonconst to]
toHsConstCastFnName :: Constness -> Class -> LH.Generator String
toHsConstCastFnName cst cls =
LH.inFunction "toHsConstCastFnName" $
LH.addExtNameModule (classExtName cls) $ toHsConstCastFnName' cst cls
toHsConstCastFnName' :: Constness -> Class -> String
toHsConstCastFnName' cst cls =
concat ["cast", toHsDataTypeName' Nonconst cls,
case cst of
Const -> "ToConst"
Nonconst -> "ToNonconst"]
toHsDataTypeName :: Constness -> Class -> LH.Generator String
toHsDataTypeName cst cls =
LH.inFunction "toHsDataTypeName" $
LH.addExtNameModule (classExtName cls) $ toHsDataTypeName' cst cls
toHsDataTypeName' :: Constness -> Class -> String
toHsDataTypeName' cst cls = LH.toHsTypeName' cst $ classExtName cls
toHsDataCtorName :: LH.Managed -> Constness -> Class -> LH.Generator String
toHsDataCtorName m cst cls =
LH.inFunction "toHsDataCtorName" $
LH.addExtNameModule (classExtName cls) $ toHsDataCtorName' m cst cls
toHsDataCtorName' :: LH.Managed -> Constness -> Class -> String
toHsDataCtorName' m cst cls = case m of
LH.Unmanaged -> base
LH.Managed -> base ++ "Gc"
where base = toHsDataTypeName' cst cls
toHsClassDeleteFnName' :: Class -> String
toHsClassDeleteFnName' cls = 'd':'e':'l':'e':'t':'e':'\'':toHsDataTypeName' Nonconst cls
toHsClassDeleteFnPtrName' :: Class -> String
toHsClassDeleteFnPtrName' cls =
'd':'e':'l':'e':'t':'e':'P':'t':'r':'\'':toHsDataTypeName' Nonconst cls
toHsCtorName :: Class -> Ctor -> LH.Generator String
toHsCtorName cls ctor =
LH.inFunction "toHsCtorName" $
toHsClassEntityName cls $ fromExtName $ ctorExtName ctor
toHsCtorName' :: Class -> Ctor -> String
toHsCtorName' cls ctor =
toHsClassEntityName' cls $ fromExtName $ ctorExtName ctor
toHsMethodName :: Class -> Method -> LH.Generator String
toHsMethodName cls method =
LH.inFunction "toHsMethodName" $
toHsClassEntityName cls $ fromExtName $ methodExtName method
toHsMethodName' :: Class -> Method -> String
toHsMethodName' cls method =
toHsClassEntityName' cls $ fromExtName $ methodExtName method
toHsClassEntityName :: IsFnName String name => Class -> name -> LH.Generator String
toHsClassEntityName cls name =
LH.addExtNameModule (classExtName cls) $ toHsClassEntityName' cls name
toHsClassEntityName' :: IsFnName String name => Class -> name -> String
toHsClassEntityName' cls name =
lowerFirst $ fromExtName $
classEntityForeignName' cls $
case toFnName name of
FnName name' -> toExtName name'
FnOp op -> operatorPreferredExtName op
sayCppExportVar ::
Type
-> Maybe (Type, Type)
-> Bool
-> ExtName
-> ExtName
-> LC.Generator ()
-> LC.Generator ()
sayCppExportVar t maybeThisTypes gettable getterName setterName sayVarName = do
let (isConst, deconstType) = case t of
Internal_TConst t' -> (True, t')
t' -> (False, t')
when gettable $
Function.sayCppExportFn getterName
(Function.VarRead sayVarName)
(fmap fst maybeThisTypes)
[]
deconstType
mempty
True
unless isConst $
Function.sayCppExportFn setterName
(Function.VarWrite sayVarName)
(fmap snd maybeThisTypes)
[toParameter $ deconstType]
voidT
mempty
True
sayHsExportVar ::
LH.SayExportMode
-> Type
-> Maybe Class
-> Bool
-> ExtName
-> ExtName
-> ExtName
-> ExtName
-> LH.Generator ()
sayHsExportVar mode
t
classIfNonstatic
gettable
getterExtName
getterForeignName
setterExtName
setterForeignName = do
let (isConst, deconstType) = case t of
Internal_TConst t' -> (True, t')
t' -> (False, t')
when gettable $
Function.sayHsExportFn
mode
getterExtName
getterForeignName
Nonpure
(maybe [] (\cls -> [toParameter $ ptrT $ constT $ objT cls]) classIfNonstatic)
deconstType
mempty
unless isConst $
Function.sayHsExportFn
mode
setterExtName
setterForeignName
Nonpure
(maybe [toParameter deconstType]
(\cls -> [toParameter $ ptrT $ objT cls, toParameter deconstType])
classIfNonstatic)
voidT
mempty