{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.Class -- Copyright : (c) 2011-2017 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module FFICXX.Generate.Type.Class where import Control.Applicative ( (<$>),(<*>) ) import Control.Monad.State import Data.Char import Data.Default ( Default(def) ) import Data.List import qualified Data.Map as M import Data.Monoid ( (<>) ) import Language.Haskell.Exts.Syntax ( Asst(..), Context, Splice(..), Type(..) ) import System.FilePath -- import FFICXX.Generate.Util import FFICXX.Generate.Util.HaskellSrcExts -- some type aliases -- | C types data CTypes = CTString | CTChar | CTInt | CTUInt | CTLong | CTULong | CTDouble | CTBool | CTDoubleStar | CTVoidStar | CTIntStar | CTCharStarStar | CPointer CTypes | CRef CTypes deriving Show -- | C++ types data CPPTypes = CPTClass Class | CPTClassRef Class | CPTClassCopy Class deriving Show -- | const flag data IsConst = Const | NoConst deriving Show data Types = Void | SelfType | CT CTypes IsConst | CPT CPPTypes IsConst | TemplateApp { tapp_hstemplate :: TemplateClass , tapp_HaskellTypeForParam :: String , tapp_CppTypeForParam :: String } | TemplateAppRef { tappref_hstemplate :: TemplateClass , tappref_HaskellTypeForParam :: String , tappref_CppTypeForParam :: String } | TemplateType TemplateClass | TemplateParam String deriving Show cvarToStr :: CTypes -> IsConst -> String -> String cvarToStr ctyp isconst varname = ctypToStr ctyp isconst <> " " <> 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" -- Currently available solution CTDoubleStar -> "double *" CTVoidStar -> "void*" CTIntStar -> "int*" CTCharStarStar -> "char**" CPointer s -> ctypToStr s NoConst <> "*" CRef s -> ctypToStr s NoConst <> "*" in case isconst of Const -> "const" <> " " <> 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 intref_ :: Types intref_ = CT (CRef CTInt) 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) intref :: String -> (Types, String) intref var = (intref_, 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) cppclasscopy_ :: Class -> Types cppclasscopy_ c = CPT (CPTClassCopy c) NoConst cppclasscopy :: Class -> String -> (Types, String) cppclasscopy c vname = (cppclasscopy_ 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 <> ")" hsCTypeName (CRef t) = "(Ptr " <> hsCTypeName t <> ")" ------------- 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 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 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 (TemplateApp _ _ _,varname) = "void* " <> varname argToString (TemplateAppRef _ _ _,varname) = "void* " <> varname 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 (CT (CRef _) _,varname) = "(*"<> varname<> ")" 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 (TemplateApp _ _ cp,varname) = "to_nonconst<"<>str<>",void>("<>varname<>")" where str = cp argToCallString (TemplateAppRef _ _ cp,varname) = "*( ("<> str <> "*) " <>varname<>")" where str = cp 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) _) = class_name c <> "_p" rettypeToString (CPT (CPTClassRef c) _) = class_name c <> "_p" rettypeToString (CPT (CPTClassCopy c) _) = class_name c <> "_p" rettypeToString (TemplateApp _ _ _) = "void*" rettypeToString (TemplateAppRef _ _ _) = "void*" rettypeToString (TemplateType _) = "void*" rettypeToString (TemplateParam _) = "Type ## _p" tmplArgToString :: TemplateClass -> (Types,String) -> String tmplArgToString _ (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname tmplArgToString t (SelfType, varname) = tclass_oname t <> "* " <> varname tmplArgToString _ (CPT (CPTClass c) isconst, varname) = case isconst of Const -> "const_" <> class_name c <> "_p " <> varname NoConst -> class_name c <> "_p " <> varname tmplArgToString _ (CPT (CPTClassRef c) isconst, varname) = case isconst of Const -> "const_" <> class_name c <> "_p " <> varname NoConst -> class_name c <> "_p " <> varname tmplArgToString _ (TemplateApp _ _ _,_v) = error "tmpArgToString: TemplateApp" tmplArgToString _ (TemplateAppRef _ _ _,_v) = error "tmpArgToString: TemplateAppRef" tmplArgToString _ (TemplateType _,v) = "void* " <> v tmplArgToString _ (TemplateParam _,v) = "Type " <> v tmplArgToString _ _ = error "tmplArgToString: undefined" tmplAllArgsToString :: Selfness -> TemplateClass -> Args -> String tmplAllArgsToString s t args = let args' = case s of Self -> (TemplateType t, "p") : args NoSelf -> args in intercalateWith conncomma (tmplArgToString t) args' tmplArgToCallString :: (Types,String) -> String tmplArgToCallString (CPT (CPTClass c) _,varname) = "to_nonconst<"<>str<>","<>str<>"_t>("<>varname<>")" where str = class_name c tmplArgToCallString (CPT (CPTClassRef c) _,varname) = "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = class_name c tmplArgToCallString (CT (CRef _) _,varname) = "(*"<> varname<> ")" tmplArgToCallString (_,varname) = varname tmplAllArgsToCallString :: Args -> String tmplAllArgsToCallString = intercalateWith conncomma tmplArgToCallString tmplRetTypeToString :: Bool -- ^ is Simple type? -> Types -> String tmplRetTypeToString _ (CT ctyp isconst) = ctypToStr ctyp isconst tmplRetTypeToString _ Void = "void" tmplRetTypeToString _ SelfType = "void*" tmplRetTypeToString _ (CPT (CPTClass c) _) = class_name c <> "_p" tmplRetTypeToString _ (CPT (CPTClassRef c) _) = class_name c <> "_p" tmplRetTypeToString _ (CPT (CPTClassCopy c) _) = class_name c <> "_p" tmplRetTypeToString _ (TemplateApp _ _ _) = "void*" tmplRetTypeToString _ (TemplateAppRef _ _ _) = "void*" tmplRetTypeToString _ (TemplateType _) = "void*" tmplRetTypeToString b (TemplateParam _) = if b then "Type" else "Type ## _p" -------- newtype ProtectedMethod = Protected { unProtected :: [String] } deriving (Monoid) data AddCInc = AddCInc FilePath String data AddCSrc = AddCSrc FilePath String data Cabal = Cabal { cabal_pkgname :: String , cabal_cheaderprefix :: String , cabal_moduleprefix :: String , cabal_additional_c_incs :: [AddCInc] , cabal_additional_c_srcs :: [AddCSrc] } data CabalAttr = CabalAttr { cabalattr_license :: Maybe String , cabalattr_licensefile :: Maybe String , cabalattr_extraincludedirs :: [FilePath] , cabalattr_extralibdirs :: [FilePath] , cabalattr_extrafiles :: [FilePath] } instance Default CabalAttr where def = CabalAttr { cabalattr_license = Nothing , cabalattr_licensefile = Nothing , cabalattr_extraincludedirs = [] , cabalattr_extralibdirs = [] , cabalattr_extrafiles = [] } 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] } 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) data TemplateFunction = TFun { tfun_ret :: Types , tfun_name :: String , tfun_oname :: String , tfun_args :: Args , tfun_alias :: Maybe String } | TFunNew { tfun_new_args :: Args } | TFunDelete -- deriving (Show,Eq,Ord) data TemplateClass = TmplCls { tclass_cabal :: Cabal , tclass_name :: String , tclass_oname :: String , tclass_param :: String , tclass_funcs :: [TemplateFunction] } -- deriving (Show,Eq,Ord) instance Show TemplateClass where show x = show (tclass_name x <> " " <> tclass_param x) instance Eq TemplateClass where (==) x y = tclass_name x == tclass_name y 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] 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) getTClassModuleBase :: TemplateClass -> String getTClassModuleBase = (<.>) <$> (cabal_moduleprefix.tclass_cabal) <*> (fst.hsTemplateClassName) -- | Daughter map not including itself 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 -- | Daughter Map including itself as a daughter 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 (CT (CRef t) _) = hsCTypeName (CRef t) ctypToHsTyp _c (CPT (CPTClass c') _) = (fst . hsClassName) c' ctypToHsTyp _c (CPT (CPTClassRef c') _) = (fst . hsClassName) c' ctypToHsTyp _c (CPT (CPTClassCopy c') _) = (fst . hsClassName) c' ctypToHsTyp _c (TemplateApp t p _) = "("<> tclass_name t <> " " <> p <> ")" ctypToHsTyp _c (TemplateAppRef t p _) = "("<> tclass_name t <> " " <> p <> ")" ctypToHsTyp _c (TemplateType t) = "("<> tclass_name t <> " " <> tclass_param t <> ")" ctypToHsTyp _c (TemplateParam p) = "("<> p <> ")" -- | convertC2HS :: CTypes -> Type () convertC2HS CTString = tycon "CString" convertC2HS CTChar = tycon "CChar" convertC2HS CTInt = tycon "CInt" convertC2HS CTUInt = tycon "CUInt" convertC2HS CTLong = tycon "CLong" convertC2HS CTULong = tycon "CULong" convertC2HS CTDouble = tycon "CDouble" convertC2HS CTDoubleStar = tyapp (tycon "Ptr") (tycon "CDouble") convertC2HS CTBool = tycon "CInt" convertC2HS CTVoidStar = tyapp (tycon "Ptr") unit_tycon convertC2HS CTIntStar = tyapp (tycon "Ptr") (tycon "CInt") convertC2HS CTCharStarStar = tyapp (tycon "Ptr") (tycon "CString") convertC2HS (CPointer t) = tyapp (tycon "Ptr") (convertC2HS t) convertC2HS (CRef t) = tyapp (tycon "Ptr") (convertC2HS t) -- | convertCpp2HS :: Maybe Class -> Types -> Type () convertCpp2HS _c Void = unit_tycon convertCpp2HS (Just c) SelfType = tycon ((fst.hsClassName) c) convertCpp2HS Nothing SelfType = error "convertCpp2HS : SelfType but no class " convertCpp2HS _c (CT t _) = convertC2HS t convertCpp2HS _c (CPT (CPTClass c') _) = (tycon . fst . hsClassName) c' convertCpp2HS _c (CPT (CPTClassRef c') _) = (tycon . fst . hsClassName) c' convertCpp2HS _c (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c' convertCpp2HS _c (TemplateApp t p _) = tyapp (tycon (tclass_name t)) (tycon p) convertCpp2HS _c (TemplateAppRef t p _) = tyapp (tycon (tclass_name t)) (tycon p) convertCpp2HS _c (TemplateType t) = tyapp (tycon (tclass_name t)) (mkTVar (tclass_param t)) convertCpp2HS _c (TemplateParam p) = mkTVar p -- | convertCpp2HS4Tmpl :: Type () -> Maybe Class -> Type () -> Types -> Type () convertCpp2HS4Tmpl _ _c _ Void = unit_tycon convertCpp2HS4Tmpl _ (Just c) _ SelfType = tycon ((fst.hsClassName) c) convertCpp2HS4Tmpl _ Nothing _ SelfType = error "convertCpp2HS4Tmpl : SelfType but no class " convertCpp2HS4Tmpl _ _c _ (CT t _) = convertC2HS t convertCpp2HS4Tmpl _ _c _ (CPT (CPTClass c') _) = (tycon . fst . hsClassName) c' convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassRef c') _) = (tycon . fst . hsClassName) c' convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c' convertCpp2HS4Tmpl e _c _ (TemplateApp _ _ _ ) = e convertCpp2HS4Tmpl e _c _ (TemplateAppRef _ _ _ ) = e convertCpp2HS4Tmpl e _c _ (TemplateType _) = e convertCpp2HS4Tmpl _ _c t (TemplateParam _) = t typeclassName :: Class -> String typeclassName c = 'I' : fst (hsClassName c) typeclassNameT :: TemplateClass -> String typeclassNameT c = 'I' : fst (hsTemplateClassName c) typeclassNameFromStr :: String -> String typeclassNameFromStr = ('I':) hsClassName :: Class -> (String, String) -- ^ High-level, 'Raw'-level hsClassName c = let cname = maybe (class_name c) id (class_alias c) in (cname, "Raw" <> cname) hsTemplateClassName :: TemplateClass -> (String, String) -- ^ High-level, 'Raw'-level hsTemplateClassName t = let tname = tclass_name t in (tname, "Raw" <> tname) existConstructorName :: Class -> String existConstructorName c = 'E' : (fst.hsClassName) c 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" classConstraints :: Class -> Context () classConstraints = cxTuple . map ((\n->classA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents extractArgRetTypes :: Maybe Class -> Bool -> (Args,Types) -> ([Type ()],[Asst ()]) extractArgRetTypes mc isvirtual (args,ret) = let (typs,s) = flip runState ([],(0 :: Int)) $ do as <- mapM (mktyp . fst) args r <- case ret of SelfType -> case mc of Nothing -> error "extractArgRetTypes: SelfType return but no class" Just c -> if isvirtual then return (mkTVar "a") else return $ tycon ((fst.hsClassName) c) x -> (return . tycon . ctypToHsTyp Nothing) x return (as ++ [tyapp (tycon "IO") r]) in (typs,fst s) where addclass c = do (ctxts,n) <- get let cname = (fst.hsClassName) c iname = typeclassNameFromStr cname tvar = mkTVar ('c' : show n) ctxt1 = classA (unqual iname) [tvar] ctxt2 = classA (unqual "FPtr") [tvar] put (ctxt1:ctxt2:ctxts,n+1) return tvar addstring = do (ctxts,n) <- get let tvar = mkTVar ('c' : show n) ctxt = classA (unqual "Castable") [tvar,tycon "CString"] put (ctxt:ctxts,n+1) return tvar mktyp typ = case typ of SelfType -> return (mkTVar "a") CT CTString Const -> addstring CT _ _ -> return $ tycon (ctypToHsTyp Nothing typ) CPT (CPTClass c') _ -> addclass c' CPT (CPTClassRef c') _ -> addclass c' -- it is not clear whether the following is okay or not. (TemplateApp t p _) -> return (tyapp (tycon (tclass_name t)) (tycon p)) (TemplateAppRef t p _) -> return (tyapp (tycon (tclass_name t)) (tycon p)) (TemplateType t) -> return (tyapp (tycon (tclass_name t)) (mkTVar (tclass_param t))) (TemplateParam p) -> return (mkTVar p) Void -> return unit_tycon _ -> error ("No such c type : " <> show typ) functionSignature :: Class -> Function -> Type () functionSignature c f = let (typs,assts) = extractArgRetTypes (Just c) (isVirtualFunc f) (genericFuncArgs f,genericFuncRet f) ctxt = cxTuple assts arg0 | isVirtualFunc f = (mkTVar "a" :) | isNonVirtualFunc f = (mkTVar (fst (hsClassName c)) :) | otherwise = id in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) functionSignatureT :: TemplateClass -> TemplateFunction -> Type () functionSignatureT t TFun {..} = let (hname,_) = hsTemplateClassName t tp = tclass_param t ctyp = convertCpp2HS Nothing tfun_ret arg0 = (tyapp (tycon hname) (mkTVar tp) :) lst = arg0 (map (convertCpp2HS Nothing . fst) tfun_args) in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) functionSignatureT t TFunNew {..} = let ctyp = convertCpp2HS Nothing (TemplateType t) lst = map (convertCpp2HS Nothing . fst) tfun_new_args in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) functionSignatureT t TFunDelete = let ctyp = convertCpp2HS Nothing (TemplateType t) in ctyp `tyfun` (tyapp (tycon "IO") unit_tycon) functionSignatureTT :: TemplateClass -> TemplateFunction -> Type () functionSignatureTT t f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) where (hname,_) = hsTemplateClassName t ctyp = case f of TFun {..} -> convertCpp2HS4Tmpl e Nothing spl tfun_ret TFunNew {..} -> convertCpp2HS4Tmpl e Nothing spl (TemplateType t) TFunDelete -> unit_tycon e = tyapp (tycon hname) spl spl = tySplice (parenSplice (mkVar (tclass_param t))) lst = case f of TFun {..} -> e : map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_args TFunNew {..} -> map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_new_args TFunDelete -> [e] -- | this is for FFI type. hsFFIFuncTyp :: Maybe (Selfness, Class) -> (Args,Types) -> Type () hsFFIFuncTyp msc (args,ret) = foldr1 tyfun $ case msc of Nothing -> argtyps <> [tyapp (tycon "IO") rettyp] Just (Self,_) -> selftyp: argtyps <> [tyapp (tycon "IO") rettyp] Just (NoSelf,_) -> argtyps <> [tyapp (tycon "IO") rettyp] where argtyps :: [Type ()] argtyps = map (hsargtype . fst) args rettyp :: Type () rettyp = hsrettype ret selftyp = case msc of Just (_,c) -> tyapp tyPtr (tycon (snd (hsClassName c))) Nothing -> error "hsFFIFuncTyp: no self for top level function" hsargtype :: Types -> Type () hsargtype (CT ctype _) = tycon (hsCTypeName ctype) hsargtype (CPT (CPTClass d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d) hsargtype (CPT (CPTClassRef d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d) hsargtype (TemplateApp t p _) = tyapp tyPtr (tyapp (tycon rawname) (tycon p)) where rawname = snd (hsTemplateClassName t) hsargtype (TemplateAppRef t p _) = tyapp tyPtr (tyapp (tycon rawname) (tycon p)) where rawname = snd (hsTemplateClassName t) hsargtype (TemplateType t) = tyapp tyPtr (tyapp (tycon rawname) (mkTVar (tclass_param t))) where rawname = snd (hsTemplateClassName t) hsargtype (TemplateParam p) = mkTVar p hsargtype SelfType = selftyp hsargtype _ = error "hsFuncTyp: undefined hsargtype" --------------------------------------------------------- hsrettype Void = unit_tycon hsrettype SelfType = selftyp hsrettype (CT ctype _) = tycon (hsCTypeName ctype) hsrettype (CPT (CPTClass d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d) hsrettype (CPT (CPTClassRef d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d) hsrettype (CPT (CPTClassCopy d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d) hsrettype (TemplateApp t p _) = tyapp tyPtr (tyapp (tycon rawname) (tycon p)) where rawname = snd (hsTemplateClassName t) hsrettype (TemplateAppRef t p _) = tyapp tyPtr (tyapp (tycon rawname) (tycon p)) where rawname = snd (hsTemplateClassName t) hsrettype (TemplateType t) = tyapp tyPtr (tyapp (tycon rawname) (mkTVar (tclass_param t))) where rawname = snd (hsTemplateClassName t) hsrettype (TemplateParam p) = mkTVar p