Hs2lib-0.4.8: WinDll/Structs/MShow/CSharp.hs
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- MShow instances for the CSharp datatypes
--
-----------------------------------------------------------------------------
module WinDll.Structs.MShow.CSharp where
import WinDll.Structs.MShow.MShow
import WinDll.Structs.Folds.CSharp
import WinDll.Structs.Folds.C
import WinDll.Structs.CSharp
import WinDll.Structs.C hiding (Normal)
import WinDll.Structs.Structures
import Data.Char
import Data.List
instance MShow CsInclude where
mshow = foldInclude ((\a->"using "++a++";")
,(\a->"using WinDll."++a++";")
) . csUnpackInclude
instance MShow CsDataEnum where
mshow = foldDataEnum ((\a b->let fix = foldr1 (\a b->a++", "++b) . map (("c"++a)++)
in "public enum List"++a++" {" ++ fix b ++ "};")) . csUnpackEnum
instance MShow Attr where
mshow = foldAttr (\p k v -> let pre = case p of
Normal -> ""
Param -> "param: "
Return -> "return: "
in pre ++ k ++ "(" ++ intercalate "," v ++ ")" )
instance MShow Argument where
mshow = mshowM 1
mshowM 1 = foldArgument (\t ty nm -> let at = "public " ++ ty ++ " " ++ nm ++ ";"
in if null t then at else unlines $ map (\x-> "[" ++ mshow x ++"]") t ++ [at])
mshowM 2 = foldArgument (\t ty nm -> let at = ty ++ " " ++ nm
in if null t then at else concat $ ["[" ++ intercalate ", " (map mshow t) ++ "]", at])
instance MShow CsExport where
mshow = foldCsExport (\c t n r a-> let comments_body = zipWith ($) (repeat ("/// "++)) c
params_decl = map (\(Argument _ _ n) -> "/// <param name=\"" ++ n ++ "\"></param>") a
result_decl = if r == "void" then [] else ["/// <returns> </returns>"]
comments = ("/// <summary>" : comments_body)
++ ("/// </summary>" : params_decl)
++ result_decl
attributes = if null t then [] else map (\x-> "[" ++ mshow x ++"]") t
arguments = "(" ++ intercalate ", " (map (mshowM 2) a) ++ ")"
decl = if '*' `elem` arguments || '*' `elem` r
then "public unsafe static extern "
else "public static extern "
in unlines $ comments ++ attributes ++ [decl ++ r ++ " " ++ n ++ arguments ++ ";",""])
instance MShow CsStruct where
mshow cs = let attr = map (\x-> "[" ++ mshow x ++"]") (cssTopAttr cs)
indent' x = " " ++ x
args = concatMap (map indent'.lines.mshow) (cssElements cs)
in unlines $ attr ++
["public unsafe struct " ++ cssName cs
,"{"
] ++ args ++
["};"
,""
]
instance MShow CsCallback where
mshow cs = let attr = map (\x-> "[" ++ mshow x ++"]") (cscTopAttr cs)
indent' x = " " ++ x
args = intercalate "," (map (mshowM 2) (cscArguments cs))
ret = cscRetType cs
unsafe = if '*' `elem` args || '*' `elem` ret then "unsafe " else ""
in unlines $ attr ++ ["public " ++ unsafe ++ "delegate " ++ ret ++ " " ++ (cscName cs) ++ "(" ++ args ++ ");"]
instance MShow CSharp where
mshow cs = let nm = "namespace " ++ _namespace cs
indent = (" " ++)
csexp = concatMap (map indent.lines.mshow) $ _functions cs
cspre = let cs' = _preserved cs
val = (indent "/// Preserved export statements") : (concatMap (map indent.lines.mshow) cs')
in if null cs' then [] else val
csrts = let cs' = _rtscontrol cs
val = (indent "/// Runtime control methods") : (concatMap (map indent.lines.mshow) cs')
in if null cs' then [] else val
csenum = let cs' = _enums cs
val = (indent "/// Constructor Enumerations") : (concatMap (map indent.lines.mshow) cs')
in if null cs' then [] else val
csstrc = let cs' = _structs cs
in concatMap (map indent.lines.mshow) cs'
csback = let cs' = _callbacks cs
val = (indent "/// Callback functions ") : (concatMap (map indent.lines.mshow) cs')
in if null cs' then [] else val
imports = map mshow (_includes cs)
in unlines $ imports ++ [""
,nm
,"{"
] ++
zipWith id (repeat (" /// "++)) (lines $ _header cs) ++
[" public unsafe class " ++ _class cs
," {"
] ++ [""] ++
csback ++ [""] ++
csexp ++
cspre ++
csrts ++
[" }"
,"}"
,nm ++ ".Types"
,"{" ] ++
zipWith id (repeat (" /// "++)) (lines $ _header cs) ++
csenum ++ [""] ++
csstrc ++
["}"
]