----------------------------------------------------------------------------- -- | -- Module : Windll -- Copyright : (c) Tamar Christina 2009 - 2010 -- License : BSD3 -- -- Maintainer : tamar@zhox.com -- Stability : experimental -- Portability : portable -- -- Generates the needed Haskell code to make calls to the generated DLL -- ----------------------------------------------------------------------------- module WinDll.CodeGen.CSharp.CSharp where import WinDll.CodeGen.Lookup import qualified WinDll.CodeGen.C as CG import WinDll.Structs.Structures import WinDll.Utils.Feedback import WinDll.Builder import WinDll.Identifier import WinDll.Session.Hs2lib import WinDll.Structs.C hiding (Normal) import WinDll.Structs.CSharp import qualified WinDll.Structs.CSharp as Cs import WinDll.Structs.MShow.MShow import WinDll.Structs.MShow.CSharp import WinDll.Structs.MShow.C import WinDll.Structs.Folds.HaskellSrcExts import WinDll.Utils.HaddockRead import Data.List import Data.Char import Data.Maybe import Data.Generics (everywhere,mkT) import qualified Data.Map as M import Control.Monad import qualified Language.Haskell.Exts as Exts -- | Write out the main header file and the definition file for the exports writeCsFiles :: Component writeCsFiles = do inform _normal "Generating C# files for pipeline" modInfo <- generateMain session <- get ann <- makeSessionAnn doclist <- getDocumentationInfo let name = namespace session spec = (specs.pipeline) session natives = (n_exports.workingset) session datatypes = d1++d2 functions = modFunctions modInfo (d1 , d2) = modDatatypes modInfo exports = modExports modInfo callbacks = modCallbacks modInfo callconv = call session defs = natives ++ manualdef ++ debugdefs natDefs = natives ++ debugdefs modnm = [] ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) ptType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "Ptr"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) ftType = Exts.TyFun ptType ctType manualdef = if dllmanual session -- | we're going to threat the Hs* functions as if they were just normal haskell functions, with type IO () then [HaskellExport callconv ann $ Export "HsStart" "HsStart" ctType ctType modnm ,HaskellExport callconv ann $ Export "HsEnd" "HsEnd" ctType ctType modnm] else [] debugdefs = if debugging session then case callconv of StdCall -> [HaskellExport callconv ann $ Export "Ex.freeS" "freeS" ftType ftType modnm ,HaskellExport callconv ann $ Export "Ex.recordS" "recordS" ftType ftType modnm] CCall -> [HaskellExport callconv ann $ Export "Ex.freeC" "freeC" ftType ftType modnm ,HaskellExport callconv ann $ Export "Ex.recordS" "recordS" ftType ftType modnm] else [] inform _detail "Creating C# structures & function header file" createComponent (name++".cs") (return $ mshow $ generateCsFile exports doclist callbacks natDefs manualdef callconv name datatypes ann) generateCsFile :: [Export] -> IndexedInterface -> [Callback] -> [HaskellExport] -> [HaskellExport] -> CallConvention -> String -> DataTypes -> Ann -> CSharp generateCsFile exps docs calls natives defs callconv classname dtypes ann = let makeCsExport (Export _ n t _ modnm) = let x = createCsType (annWorkingSetCs ann) t restype = swapList (last x) rest = case length x > 1 of True -> init x False -> [] names = ["arg"++show n|n<-[1..(length x-1)]] resp = foldl (\a b->a ++ " " ++ b) "" . lines args = zipWith mkArg names rest callc = if callconv == CCall then "CallingConvention=CallingConvention.Cdecl" else "CallingConvention=CallingConvention.StdCall" comments = (n ++ " ::" ++ (resp $ mshowM 2 t)) : (maybe [] id (fmap (\x->map ("// "++) (description x)) $ M.lookup n docs)) in CsExport { cseComments = comments , cseTopAttr = [Attr Cs.Normal "DllImport" ["\"" ++ classname++".dll\"", callc, "CharSet = CharSet.Unicode"] ] ++ lookupRetAttr restype , cseName = n , cseRetType = restype , cseArguments = args } mkArg nm ty = Argument (lookupAttr ty) ty nm makeCsCallback (Callback nm t _ _ _) = let conv = if callconv == CCall then "CallingConvention.Cdecl" else "CallingConvention.StdCall" attr = [Attr Cs.Normal "UnmanagedFunctionPointer" [conv]] x = createCsType (annWorkingSetCs ann) t restype = last x rest = case length x > 1 of True -> init x False -> [] names = ["arg"++show n|n<-[1..(length x-1)]] resp = foldl (\a b->a ++ " " ++ b) "" . lines args = zipWith mkArg names rest in CsCallback { cscName = nm , cscTopAttr = attr ++ lookupRetAttr restype , cscRetType = restype , cscArguments = args } (enums, forwards, structs) = unzip3 (map (CG.generateCCode (lookupCs (annWorkingSetCs ann) True)) dtypes) in CSharp { _functions = map makeCsExport exps , _preserved = map (\(HaskellExport clp _ e) -> makeCsExport e) natives , _rtscontrol = map (\(HaskellExport clp _ e) -> makeCsExport e) defs , _callbacks = map makeCsCallback calls , _callconv = callconv , _header = mkHeader , _namespace = "WinDll.Generated" , _class = classname , _includes = map CsInclude [LibInclude "System" ,LibInclude "System.Collections.Generic" ,LibInclude "System.Linq" ,LibInclude "System.Text" ,LibInclude "System.Runtime.InteropServices" ,LibInclude "WinDll" ,LocalInclude "Utils" ,LocalInclude $ "Generated.Types." ++ classname ] , _structs = map upgradeField (join structs) , _typeDecls = [] , _enums = map CsDataEnum (join enums) } -- | Generate C# structs from the datatype declarations upgradeField :: DataField -> CsStruct upgradeField (Forward _ _) = error "Forward declarations are not needed by C#" upgradeField (Value{} ) = error "Value declarations are not directly supported by this function" upgradeField (Field NormalDef kind name _ args) = let attr = case kind of Struct -> [Attr Cs.Normal "StructLayout" ["LayoutKind.Sequential", "CharSet=CharSet.Unicode"]] Union -> [Attr Cs.Normal "StructLayout" ["LayoutKind.Explicit" , "CharSet=CharSet.Unicode"]] _ -> error "unsupported Kind value in c# conversion" styp = case kind of Struct -> CsTStruct Union -> CsTUnion _ -> error "unsupported Kind value in c# conversion" mkElements (Value _ name typ (Just nm)) = let stype = name ++ mshow typ sattr = lookupAttr stype attr = case kind of Union -> Attr Cs.Normal "FieldOffset" ["0"] : sattr _ -> sattr in Argument attr stype nm mkElements x = error $ "Argument type not supported: " ++ show x in CsStruct { cssType = styp , cssTopAttr = attr , cssName = name , cssElements = map mkElements args } upgradeField (Field{} ) = error "Typedef field declarations are not supported" -- | Lookup Attributes for struct paramaters -- these get prefixed with 'param: ' lookupArgAttr :: String -> [Attr] lookupArgAttr ty = [ Attr Cs.Param k v | (Attr _ k v) <- lookupAttr ty] -- | Lookup Attributes for fucntion return paramaters -- these get prefixed with 'return: ' lookupRetAttr :: String -> [Attr] lookupRetAttr ty = [ Attr Cs.Return k v | (Attr _ k v) <- lookupAttr ty ] -- | Perform a lookup of marshalling attributes for a type lookupAttr :: String -> [Attr] lookupAttr ty = if "CBF" `isPrefixOf` ty then [Attr Cs.Normal "MarshalAs" ["UnmanagedType.FunctionPtr"]] else maybe [] id (lookup ty attlist) -- | List containing mapping to C# Attributes from type attlist ::[(String , [Attr] )] attlist = [("String" , mk "LPWStr" ) ,("StringBuilder", mk "LPWStr" ) ,("char*" , [] ) ,("Int" , [] ) ,("Int8" , mk "SByte" ) ,("Int16" , mk "I2" ) ,("Int32" , mk "I4" ) ,("Int64" , mk "I8" ) ,("Word8" , mk "U1" ) ,("Word16" , mk "U2" ) ,("Word32" , mk "U4" ) ,("Word64" , mk "U8" ) ,("Float" , [] ) ,("Double" , [] ) ,("CWString" , mk "LPWStr" ) ,("CInt" , mk "I4" ) ,("Bool" , mk "I1" ) ,("FastString" , mk "LPWStr" ) ,("FastInt" , mk "I4" ) ,("Char" , [] ) ,("CWchar" , [] ) ,("CChar" , [] ) ,("Integer" , mk "I8" ) ,("Rational" , mk "I8" ) ,("StablePtr" , [] ) ,("()" , [] )] where mk x = [Attr Cs.Normal "MarshalAs" ["UnmanagedType." ++ x]]