Hs2lib-0.6.3: 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.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]]