----------------------------------------------------------------------------- -- | -- 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 import WinDll.Structs.C hiding (Normal) import WinDll.Structs.CSharp 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 ctType = Exts.TyApp (Exts.TyCon (Exts.UnQual (Exts.Ident "IO"))) (Exts.TyCon (Exts.Special Exts.UnitCon)) 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 ,HaskellExport callconv ann $ Export "HsEnd" "HsEnd" ctType ctType] else [] inform _detail "Creating C# structures & function header file" createComponent (name++".cs") (return $ mshow $ generateCsFile exports doclist callbacks natives 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 _) = 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 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 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" ] , _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 Normal "StructLayout" ["LayoutKind.Sequential", "CharSet=CharSet.Unicode"]] Union -> [Attr 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 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 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 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 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" ) ,("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 Normal "MarshalAs" ["UnmanagedType." ++ x]]