module FFICXX.Generate.Type.Class where
import Control.Applicative ((<$>),(<*>))
import Data.Char
import Data.List
import Data.Monoid
import qualified Data.Map as M
import System.FilePath
import FFICXX.Generate.Util
data CTypes = CTString
| CTChar
| CTInt
| CTUInt
| CTLong
| CTULong
| CTDouble
| CTBool
| CTDoubleStar
| CTVoidStar
| CTIntStar
| CTCharStarStar
| CPointer CTypes
deriving Show
data CPPTypes = CPTClass Class
| CPTClassRef Class
deriving Show
data IsConst = Const | NoConst
deriving Show
data Types = Void
| SelfType
| CT CTypes IsConst
| CPT CPPTypes IsConst
deriving Show
cvarToStr :: CTypes -> IsConst -> String -> String
cvarToStr ctyp isconst varname = (ctypToStr ctyp isconst) `connspace` varname
ctypToStr :: CTypes -> IsConst -> String
ctypToStr ctyp isconst =
let typword = case ctyp of
CTString -> "char*"
CTChar -> "char"
CTInt -> "int"
CTUInt -> "unsigned int"
CTLong -> "signed long"
CTULong -> "long unsigned int"
CTDouble -> "double"
CTBool -> "int"
CTDoubleStar -> "double *"
CTVoidStar -> "void*"
CTIntStar -> "int*"
CTCharStarStar -> "char**"
CPointer s -> ctypToStr s NoConst ++ "*"
in case isconst of
Const -> "const" `connspace` typword
NoConst -> typword
self_ :: Types
self_ = SelfType
cstring_ :: Types
cstring_ = CT CTString Const
cint_ :: Types
cint_ = CT CTInt Const
int_ :: Types
int_ = CT CTInt NoConst
uint_ :: Types
uint_ = CT CTUInt NoConst
ulong_ :: Types
ulong_ = CT CTULong NoConst
long_ :: Types
long_ = CT CTLong NoConst
culong_ :: Types
culong_ = CT CTULong Const
clong_ :: Types
clong_ = CT CTLong Const
cchar_ :: Types
cchar_ = CT CTChar Const
char_ :: Types
char_ = CT CTChar NoConst
short_ :: Types
short_ = int_
cdouble_ :: Types
cdouble_ = CT CTDouble Const
double_ :: Types
double_ = CT CTDouble NoConst
doublep_ :: Types
doublep_ = CT CTDoubleStar NoConst
float_ :: Types
float_ = double_
bool_ :: Types
bool_ = CT CTBool NoConst
void_ :: Types
void_ = Void
voidp_ :: Types
voidp_ = CT CTVoidStar NoConst
intp_ :: Types
intp_ = CT CTIntStar NoConst
charpp_ :: Types
charpp_ = CT CTCharStarStar NoConst
star_ :: CTypes -> Types
star_ t = CT (CPointer t) NoConst
cstar_ :: CTypes -> Types
cstar_ t = CT (CPointer t) Const
self :: String -> (Types, String)
self var = (self_, var)
voidp :: String -> (Types,String)
voidp var = (voidp_ , var)
cstring :: String -> (Types,String)
cstring var = (cstring_ , var)
cint :: String -> (Types,String)
cint var = (cint_ , var)
int :: String -> (Types,String)
int var = (int_ , var)
uint :: String -> (Types,String)
uint var = (uint_ , var)
long :: String -> (Types,String)
long var = (long_, var)
ulong :: String -> (Types,String)
ulong var = (ulong_ , var)
clong :: String -> (Types,String)
clong var = (clong_, var)
culong :: String -> (Types,String)
culong var = (culong_ , var)
cchar :: String -> (Types,String)
cchar var = (cchar_ , var)
char :: String -> (Types,String)
char var = (char_ , var)
short :: String -> (Types,String)
short = int
cdouble :: String -> (Types,String)
cdouble var = (cdouble_ , var)
double :: String -> (Types,String)
double var = (double_ , var)
doublep :: String -> (Types,String)
doublep var = (doublep_ , var)
float :: String -> (Types,String)
float = double
bool :: String -> (Types,String)
bool var = (bool_ , var)
intp :: String -> (Types, String)
intp var = (intp_ , var)
charpp :: String -> (Types, String)
charpp var = (charpp_, var)
star :: CTypes -> String -> (Types, String)
star t var = (star_ t, var)
cstar :: CTypes -> String -> (Types, String)
cstar t var = (cstar_ t, var)
cppclass_ :: Class -> Types
cppclass_ c = CPT (CPTClass c) NoConst
cppclass :: Class -> String -> (Types, String)
cppclass c vname = ( cppclass_ c, vname)
cppclassconst :: Class -> String -> (Types, String)
cppclassconst c vname = ( CPT (CPTClass c) Const, vname)
cppclassref_ :: Class -> Types
cppclassref_ c = CPT (CPTClassRef c) NoConst
cppclassref :: Class -> String -> (Types, String)
cppclassref c vname = (cppclassref_ c, vname)
hsCTypeName :: CTypes -> String
hsCTypeName CTString = "CString"
hsCTypeName CTChar = "CChar"
hsCTypeName CTInt = "CInt"
hsCTypeName CTUInt = "CUInt"
hsCTypeName CTLong = "CLong"
hsCTypeName CTULong = "CULong"
hsCTypeName CTDouble = "CDouble"
hsCTypeName CTDoubleStar = "(Ptr CDouble)"
hsCTypeName CTBool = "CInt"
hsCTypeName CTVoidStar = "(Ptr ())"
hsCTypeName CTIntStar = "(Ptr CInt)"
hsCTypeName CTCharStarStar = "(Ptr (CString))"
hsCTypeName (CPointer t) = "(Ptr " ++ hsCTypeName t ++ ")"
hsCppTypeName :: CPPTypes -> String
hsCppTypeName (CPTClass c) = "(Ptr "++rawname++")" where rawname = snd (hsClassName c)
hsCppTypeName (CPTClassRef c) = "(Ptr "++rawname++")" where rawname = snd (hsClassName c)
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 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
hsFrontNameForTopLevelFunction :: TopLevelFunction -> String
hsFrontNameForTopLevelFunction tfn =
let (x:xs) = case tfn of
TopLevelFunction {..} -> maybe toplevelfunc_name id toplevelfunc_alias
TopLevelVariable {..} -> maybe toplevelvar_name id toplevelvar_alias
in toLower x : xs
data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String
, tihClassDep :: [ClassImportHeader]
, tihFuncs :: [TopLevelFunction]
}
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
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
argToString :: (Types,String) -> String
argToString (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname
argToString (SelfType, varname) = "Type ## _p " ++ varname
argToString (CPT (CPTClass c) isconst, varname) = case isconst of
Const -> "const_" ++ cname ++ "_p " ++ varname
NoConst -> cname ++ "_p " ++ varname
where cname = class_name c
argToString (CPT (CPTClassRef c) isconst, varname) = case isconst of
Const -> "const_" ++ cname ++ "_p " ++ varname
NoConst -> cname ++ "_p " ++ varname
where cname = class_name c
argToString _ = error "undefined argToString"
argsToString :: Args -> String
argsToString args =
let args' = (SelfType, "p") : args
in intercalateWith conncomma argToString args'
argsToStringNoSelf :: Args -> String
argsToStringNoSelf = intercalateWith conncomma argToString
argToCallString :: (Types,String) -> String
argToCallString (CPT (CPTClass c) _,varname) =
"to_nonconst<"++str++","++str++"_t>("++varname++")" where str = class_name c
argToCallString (CPT (CPTClassRef c) _,varname) =
"to_nonconstref<"++str++","++str++"_t>(*"++varname++")" where str = class_name c
argToCallString (_,varname) = varname
argsToCallString :: Args -> String
argsToCallString = intercalateWith conncomma argToCallString
rettypeToString :: Types -> String
rettypeToString (CT ctyp isconst) = ctypToStr ctyp isconst
rettypeToString Void = "void"
rettypeToString SelfType = "Type ## _p"
rettypeToString (CPT (CPTClass c) _) = str ++ "_p"
where str = class_name c
rettypeToString (CPT (CPTClassRef c) _) = str ++ "_p"
where str = class_name c
newtype ProtectedMethod = Protected { unProtected :: [String] }
deriving (Monoid)
data Cabal = Cabal { cabal_pkgname :: String
, cabal_cheaderprefix :: String
, cabal_moduleprefix :: String }
data Class = Class { class_cabal :: Cabal
, class_name :: String
, class_parents :: [Class]
, class_protected :: ProtectedMethod
, class_alias :: Maybe String
, class_funcs :: [Function]
}
| AbstractClass { class_cabal :: Cabal
, class_name :: String
, class_parents :: [Class]
, class_protected :: ProtectedMethod
, class_alias :: Maybe String
, class_funcs :: [Function]
}
newtype Namespace = NS { unNamespace :: String } deriving (Show)
data ClassImportHeader = ClassImportHeader
{ cihClass :: Class
, cihSelfHeader :: String
, cihNamespace :: [Namespace]
, cihSelfCpp :: String
, cihIncludedHPkgHeadersInH :: [String]
, cihIncludedHPkgHeadersInCPP :: [String]
, cihIncludedCPkgHeaders :: [String]
} deriving (Show)
data ClassModule = ClassModule
{ cmModule :: String
, cmClass :: [Class]
, cmCIH :: [ClassImportHeader]
, cmImportedModulesHighNonSource :: [String]
, cmImportedModulesRaw :: [String]
, cmImportedModulesHighSource :: [String]
, cmImportedModulesForFFI :: [String]
} deriving (Show)
data ClassGlobal = ClassGlobal
{ cgDaughterSelfMap :: DaughterMap
, cgDaughterMap :: DaughterMap
}
isAbstractClass :: Class -> Bool
isAbstractClass (Class _ _ _ _ _ _) = False
isAbstractClass (AbstractClass _ _ _ _ _ _) = True
instance Show Class where
show x = show (class_name x)
instance Eq Class where
(==) x y = class_name x == class_name y
instance Ord Class where
compare x y = compare (class_name x) (class_name y)
type DaughterMap = M.Map String [Class]
class_allparents :: Class -> [Class]
class_allparents c = let ps = class_parents c
in if null ps
then []
else nub (ps ++ (concatMap class_allparents ps))
getClassModuleBase :: Class -> String
getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (fst.hsClassName)
mkDaughterMap :: [Class] -> DaughterMap
mkDaughterMap = foldl mkDaughterMapWorker M.empty
where mkDaughterMapWorker m c = let ps = map getClassModuleBase (class_allparents c)
in foldl (addmeToYourDaughterList c) m ps
addmeToYourDaughterList c m p = let f Nothing = Just [c]
f (Just cs) = Just (c:cs)
in M.alter f p m
mkDaughterSelfMap :: [Class] -> DaughterMap
mkDaughterSelfMap = foldl worker M.empty
where worker m c = let ps = map getClassModuleBase (c:class_allparents c)
in foldl (addToList c) m ps
addToList c m p = let f Nothing = Just [c]
f (Just cs) = Just (c:cs)
in M.alter f p m
ctypToHsTyp :: Maybe Class -> Types -> String
ctypToHsTyp _c Void = "()"
ctypToHsTyp (Just c) SelfType = (fst.hsClassName) c
ctypToHsTyp Nothing SelfType = error "ctypToHsTyp : SelfType but no class "
ctypToHsTyp _c (CT CTString _) = "CString"
ctypToHsTyp _c (CT CTInt _) = "CInt"
ctypToHsTyp _c (CT CTUInt _) = "CUInt"
ctypToHsTyp _c (CT CTChar _) = "CChar"
ctypToHsTyp _c (CT CTLong _) = "CLong"
ctypToHsTyp _c (CT CTULong _) = "CULong"
ctypToHsTyp _c (CT CTDouble _) = "CDouble"
ctypToHsTyp _c (CT CTBool _ ) = "CInt"
ctypToHsTyp _c (CT CTDoubleStar _) = "(Ptr CDouble)"
ctypToHsTyp _c (CT CTVoidStar _) = "(Ptr ())"
ctypToHsTyp _c (CT CTIntStar _) = "(Ptr CInt)"
ctypToHsTyp _c (CT CTCharStarStar _) = "(Ptr CString)"
ctypToHsTyp _c (CT (CPointer t) _) = hsCTypeName (CPointer t)
ctypToHsTyp _c (CPT (CPTClass c') _) = class_name c'
ctypToHsTyp _c (CPT (CPTClassRef c') _) = class_name c'
typeclassName :: Class -> String
typeclassName c = 'I' : fst (hsClassName c)
typeclassNameFromStr :: String -> String
typeclassNameFromStr = ('I':)
hsClassName :: Class -> (String, String)
hsClassName c =
let cname = maybe (class_name c) id (class_alias c)
in (cname, "Raw" ++ cname)
existConstructorName :: Class -> String
existConstructorName c = 'E' : (fst.hsClassName) c
hsFuncTyp :: Class -> Function -> String
hsFuncTyp c f = let args = genericFuncArgs f
ret = genericFuncRet f
in selfstr ++ " -> " ++ concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret
where (_hcname,rcname) = hsClassName c
selfstr = "(Ptr " ++ rcname ++ ")"
hsargtype (CT ctype _) = hsCTypeName ctype
hsargtype (CPT x _) = hsCppTypeName x
hsargtype SelfType = selfstr
hsargtype _ = error "undefined hsargtype"
hsrettype Void = "IO ()"
hsrettype SelfType = "IO " ++ selfstr
hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype
hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x
hsFuncTypNoSelf :: Class -> Function -> String
hsFuncTypNoSelf c f = let args = genericFuncArgs f
ret = genericFuncRet f
in intercalateWith connArrow id $ map (hsargtype . fst) args ++ [hsrettype ret]
where (_hcname,rcname) = hsClassName c
selfstr = "(Ptr " ++ rcname ++ ")"
hsargtype (CT ctype _) = hsCTypeName ctype
hsargtype (CPT x _) = hsCppTypeName x
hsargtype SelfType = selfstr
hsargtype _ = error "undefined hsargtype"
hsrettype Void = "IO ()"
hsrettype SelfType = "IO " ++ selfstr
hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype
hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x
hscFuncName :: Class -> Function -> String
hscFuncName c f = "c_" ++ toLowers (class_name c) ++ "_" ++ toLowers (aliasedFuncName c f)
hsFuncName :: Class -> Function -> String
hsFuncName c f = let (x:xs) = aliasedFuncName c f
in (toLower x) : xs
hsFuncXformer :: Function -> String
hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func)
in if len > 0
then "xform" ++ show (len 1)
else "xformnull"
hsFuncXformer func@(Static _ _ _ _) =
let len = length (genericFuncArgs func)
in if len > 0
then "xform" ++ show (len 1)
else "xformnull"
hsFuncXformer func = let len = length (genericFuncArgs func)
in "xform" ++ show len
genericFuncRet :: Function -> Types
genericFuncRet f =
case f of
Constructor _ _ -> self_
Virtual t _ _ _ -> t
NonVirtual t _ _ _-> t
Static t _ _ _ -> t
Destructor _ -> void_
genericFuncArgs :: Function -> Args
genericFuncArgs (Destructor _) = []
genericFuncArgs f = func_args f
aliasedFuncName :: Class -> Function -> String
aliasedFuncName c f =
case f of
Constructor _ a -> maybe (constructorName c) id a
Virtual _ str _ a -> maybe str id a
NonVirtual _ str _ a-> maybe (nonvirtualName c str) id a
Static _ str _ a -> maybe (nonvirtualName c str) id a
Destructor a -> maybe destructorName id a
cppStaticName :: Class -> Function -> String
cppStaticName c f = class_name c ++ "::" ++ func_name f
cppFuncName :: Class -> Function -> String
cppFuncName c f = case f of
Constructor _ _ -> "new"
Virtual _ _ _ _ -> func_name f
NonVirtual _ _ _ _-> func_name f
Static _ _ _ _-> cppStaticName c f
Destructor _ -> destructorName
constructorName :: Class -> String
constructorName c = "new" ++ (fst.hsClassName) c
nonvirtualName :: Class -> String -> String
nonvirtualName c str = (firstLower.fst.hsClassName) c ++ str
destructorName :: String
destructorName = "delete"