{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module FFICXX.Generate.Type.Class where import Data.List (intercalate) import qualified Data.Map as M import Data.Maybe (mapMaybe) import FFICXX.Generate.Type.Cabal (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_tparams :: [TemplateArgType], tapp_CppTypeForParam :: String -- TODO: remove this } deriving (Show) -- | Supported C++ types. data Types = Void | SelfType | CT CTypes IsConst | CPT CPPTypes IsConst | -- | like vector* TemplateApp TemplateAppInfo | -- | like vector& TemplateAppRef TemplateAppInfo | -- | like unique_ptr (using std::move) TemplateAppMove TemplateAppInfo | -- | template self? TODO: clarify this. TemplateType TemplateClass | TemplateParam String | -- | this is A* with template TemplateParamPointer String deriving (Show) ------------- -- | Function argument, type and variable name. data Arg = Arg { arg_type :: Types, arg_name :: String } deriving (Show) -- | Regular member functions in a ordinary class data Function = Constructor { func_args :: [Arg], func_alias :: Maybe String } | Virtual { func_ret :: Types, func_name :: String, func_args :: [Arg], func_alias :: Maybe String } | NonVirtual { func_ret :: Types, func_name :: String, func_args :: [Arg], func_alias :: Maybe String } | Static { func_ret :: Types, func_name :: String, func_args :: [Arg], func_alias :: Maybe String } | Destructor { func_alias :: Maybe String } deriving (Show) -- | Member variable. Isomorphic to Arg newtype Variable = Variable {unVariable :: Arg} deriving (Show) -- | Member functions of a template class. data TemplateMemberFunction = TemplateMemberFunction { tmf_params :: [String], tmf_ret :: Types, tmf_name :: String, tmf_args :: [Arg], tmf_alias :: Maybe String } deriving (Show) -- | Function defined at top level like ordinary C functions, -- i.e. no owning class. data TopLevel = TLOrdinary TLOrdinary | TLTemplate TLTemplate deriving (Show) filterTLOrdinary :: [TopLevel] -> [TLOrdinary] filterTLOrdinary = mapMaybe (\case TLOrdinary f -> Just f; _ -> Nothing) filterTLTemplate :: [TopLevel] -> [TLTemplate] filterTLTemplate = mapMaybe (\case TLTemplate f -> Just f; _ -> Nothing) data TLOrdinary = TopLevelFunction { toplevelfunc_ret :: Types, toplevelfunc_name :: String, toplevelfunc_args :: [Arg], toplevelfunc_alias :: Maybe String } | TopLevelVariable { toplevelvar_ret :: Types, toplevelvar_name :: String, toplevelvar_alias :: Maybe String } deriving (Show) data TLTemplate = TopLevelTemplateFunction { topleveltfunc_params :: [String], topleveltfunc_ret :: Types, topleveltfunc_name :: String, topleveltfunc_oname :: String, topleveltfunc_args :: [Arg] } 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], class_has_proxy :: Bool } | 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 OpExp = -- | unary * (deRef) operator OpStar | -- | unary prefix ++ operator -- | OpAdd Arg Arg -- | OpMul Arg Arg OpFPPlus data TemplateFunction = TFun { tfun_ret :: Types, tfun_name :: String, tfun_oname :: String, tfun_args :: [Arg] } | TFunNew { tfun_new_args :: [Arg], tfun_new_alias :: Maybe String } | TFunDelete | TFunOp { tfun_ret :: Types, -- | haskell alias for the operator tfun_name :: String, tfun_opexp :: OpExp } argsFromOpExp :: OpExp -> [Arg] argsFromOpExp OpStar = [] argsFromOpExp OpFPPlus = [] -- argsFromOpExp (OpAdd x y) = [x,y] -- argsFromOpExp (OpMul x y) = [x,y] opSymbol :: OpExp -> String opSymbol OpStar = "*" opSymbol OpFPPlus = "++" -- opSymbol (OpAdd _ _) = "+" -- opSymbol (OpMul _ _) = "*" -- TODO: Generalize this further. -- | Positional string interpolation form. -- For example, "std::map::iterator" is FormNested "std::map" "iterator"]. data Form = FormSimple String | FormNested String String data TemplateClass = TmplCls { tclass_cabal :: Cabal, tclass_name :: String, tclass_cxxform :: Form, tclass_params :: [String], tclass_funcs :: [TemplateFunction], tclass_vars :: [Variable] } -- TODO: we had better not override standard definitions instance Show TemplateClass where show x = show (tclass_name x <> " " <> intercalate " " (tclass_params 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 -- | Check having Proxy hasProxy :: Class -> Bool hasProxy c@Class {} = class_has_proxy c hasProxy AbstractClass {} = False type DaughterMap = M.Map String [Class] data Accessor = Getter | Setter deriving (Show, Eq)