{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.Class -- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module FFICXX.Generate.Type.Class where import qualified Data.Map as M import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..),(<>)) -- import FFICXX.Generate.Type.Cabal -- | C types data CTypes = CTBool | CTChar | CTClock | CTDouble | CTFile | CTFloat | CTFpos | CTInt | CTIntMax | CTIntPtr | CTJmpBuf | CTLLong | CTLong | CTPtrdiff | CTSChar | CTSUSeconds | CTShort | CTSigAtomic | CTSize | CTTime | CTUChar | CTUInt | CTUIntMax | CTUIntPtr | CTULLong | CTULong | CTUSeconds | CTUShort | CTWchar | CTInt8 | CTInt16 | CTInt32 | CTInt64 | CTUInt8 | CTUInt16 | CTUInt32 | CTUInt64 | CTVoidStar | CTString | CEnum CTypes String | CPointer CTypes | CRef CTypes deriving Show -- | C++ types data CPPTypes = CPTClass Class | CPTClassRef Class | CPTClassCopy Class | CPTClassMove Class deriving Show -- | const flag data IsConst = Const | NoConst deriving Show -- | Argument type which can be used as an template argument like float -- in vector. -- For now, this distinguishes Class and non-Class. data TemplateArgType = TArg_Class Class | TArg_TypeParam String | TArg_Other String deriving Show data TemplateAppInfo = TemplateAppInfo { tapp_tclass :: TemplateClass , tapp_tparam :: TemplateArgType , tapp_CppTypeForParam :: String } deriving Show data Types = Void | SelfType | CT CTypes IsConst | CPT CPPTypes IsConst | TemplateApp TemplateAppInfo -- ^ like vector* | TemplateAppRef TemplateAppInfo -- ^ like vector& | TemplateAppMove TemplateAppInfo -- ^ like unique_ptr (using std::move) | TemplateType TemplateClass -- ^ template self? TODO: clarify this. | TemplateParam String | TemplateParamPointer String -- ^ this is A* with template deriving Show ------------- type Args = [(Types,String)] data Function = Constructor { func_args :: Args , func_alias :: Maybe String } | Virtual { func_ret :: Types , func_name :: String , func_args :: Args , func_alias :: Maybe String } | NonVirtual { func_ret :: Types , func_name :: String , func_args :: Args , func_alias :: Maybe String } | Static { func_ret :: Types , func_name :: String , func_args :: Args , func_alias :: Maybe String } | Destructor { func_alias :: Maybe String } deriving Show data Variable = Variable { var_type :: Types , var_name :: String } deriving Show data TemplateMemberFunction = TemplateMemberFunction { tmf_param :: String , tmf_ret :: Types , tmf_name :: String , tmf_args :: Args , tmf_alias :: Maybe String } deriving Show data TopLevelFunction = TopLevelFunction { toplevelfunc_ret :: Types , toplevelfunc_name :: String , toplevelfunc_args :: Args , toplevelfunc_alias :: Maybe String } | TopLevelVariable { toplevelvar_ret :: Types , toplevelvar_name :: String , toplevelvar_alias :: Maybe String } deriving Show isNewFunc :: Function -> Bool isNewFunc (Constructor _ _) = True isNewFunc _ = False isDeleteFunc :: Function -> Bool isDeleteFunc (Destructor _) = True isDeleteFunc _ = False isVirtualFunc :: Function -> Bool isVirtualFunc (Destructor _) = True isVirtualFunc (Virtual _ _ _ _) = True isVirtualFunc _ = False isNonVirtualFunc :: Function -> Bool isNonVirtualFunc (NonVirtual _ _ _ _) = True isNonVirtualFunc _ = False isStaticFunc :: Function -> Bool isStaticFunc (Static _ _ _ _) = True isStaticFunc _ = False virtualFuncs :: [Function] -> [Function] virtualFuncs = filter isVirtualFunc constructorFuncs :: [Function] -> [Function] constructorFuncs = filter isNewFunc nonVirtualNotNewFuncs :: [Function] -> [Function] nonVirtualNotNewFuncs = filter (\x -> (not.isVirtualFunc) x && (not.isNewFunc) x && (not.isDeleteFunc) x && (not.isStaticFunc) x ) staticFuncs :: [Function] -> [Function] staticFuncs = filter isStaticFunc -------- newtype ProtectedMethod = Protected { unProtected :: [String] } deriving (Semigroup, Monoid) data ClassAlias = ClassAlias { caHaskellName :: String , caFFIName :: String } -- TODO: partial record must be avoided. data Class = Class { class_cabal :: Cabal , class_name :: String , class_parents :: [Class] , class_protected :: ProtectedMethod , class_alias :: Maybe ClassAlias , class_funcs :: [Function] , class_vars :: [Variable] , class_tmpl_funcs :: [TemplateMemberFunction] } | AbstractClass { class_cabal :: Cabal , class_name :: String , class_parents :: [Class] , class_protected :: ProtectedMethod , class_alias :: Maybe ClassAlias , class_funcs :: [Function] , class_vars :: [Variable] , class_tmpl_funcs :: [TemplateMemberFunction] } -- TODO: we had better not override standard definitions instance Show Class where show x = show (class_name x) -- TODO: we had better not override standard definitions instance Eq Class where (==) x y = class_name x == class_name y -- TODO: we had better not override standard definitions instance Ord Class where compare x y = compare (class_name x) (class_name y) data TemplateFunction = TFun { tfun_ret :: Types , tfun_name :: String , tfun_oname :: String , tfun_args :: Args , tfun_alias :: Maybe String } | TFunNew { tfun_new_args :: Args , tfun_new_alias :: Maybe String } | TFunDelete data TemplateClass = TmplCls { tclass_cabal :: Cabal , tclass_name :: String , tclass_oname :: String , tclass_param :: String , tclass_funcs :: [TemplateFunction] } -- TODO: we had better not override standard definitions instance Show TemplateClass where show x = show (tclass_name x <> " " <> tclass_param x) -- TODO: we had better not override standard definitions instance Eq TemplateClass where (==) x y = tclass_name x == tclass_name y -- TODO: we had better not override standard definitions instance Ord TemplateClass where compare x y = compare (tclass_name x) (tclass_name y) data ClassGlobal = ClassGlobal { cgDaughterSelfMap :: DaughterMap , cgDaughterMap :: DaughterMap } data Selfness = Self | NoSelf -- | Check abstract class isAbstractClass :: Class -> Bool isAbstractClass Class{} = False isAbstractClass AbstractClass{} = True type DaughterMap = M.Map String [Class] data Accessor = Getter | Setter deriving (Show, Eq)