Hs2lib-0.4.8: WinDll/CodeGen/CSharp/CSharp.hs
-----------------------------------------------------------------------------
-- |
-- 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]]