C.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- MShow instances for the C datatypes
--
-----------------------------------------------------------------------------
module WinDll.Structs.MShow.C(inline') where

import WinDll.Structs.MShow.MShow
import WinDll.Structs.Folds.C
import WinDll.Structs.C
import WinDll.Structs.Types
import WinDll.Structs.Structures(Callback(..))

import WinDll.Session.Hs2lib(genCcall)

import WinDll.CodeGen.Lookup
import WinDll.Lib.NativeMapping

import Data.Char
import Data.List

import qualified Language.Haskell.Exts as Exts

instance MShow Include where
    mshow = foldInclude ((\a->"#include <"++a++">")
                        ,(\a->"#include \""++a++"\"")
                        )
                        
instance MShow DataEnum where
    mshow = foldDataEnum ((\a b->let fix = foldr1 (\a b->a++", "++b) . map (("c"++a)++)
                                 in "enum List"++a++" {" ++ fix b ++ "};"))
            
instance MShow CDataType where
    mshow = foldCDataType ("struct"
                          ,"union"
                          ,"enum"
                          ,""
                          )
                          
instance MShow FieldType where
    mshow = foldFieldType ("","*")
    
instance MShow DataFieldType where
    mshow = foldDataFieldType ("typedef "
                              ,""
                              )
    
instance MShow DataField where
    mshow = foldDataField ((\a b c d e->unlines $ (mshow a ++ mshow b ++ " " ++ mshow c ++ " {" ):((map (indent.mshow) e) ++ ["} " ++ mshow d ++ ";"]))
                          ,(\a b c d  ->mshow a ++ " " ++ mshow b ++ mshow c ++ " " ++ mshow d ++";")
                          ,(\a b      ->"typedef " ++ mshow a++ " " ++ mshow b++ " " ++ mshow b ++ "_t;")
                          )
                          
instance MShow C where
    mshow = foldC ((\a cc cb b c d->unlines
                                         $ concat [map mshow a
                                                  ,[]
                                                  ,map mshow b 
                                                  ,[]
                                                  ,map mshow c 
                                                  ,[]
                                                  ,callback_decls cb cc
                                                  ,[] 
                                                  ,map mshow d]))
           -- declare callback function pointers
       where callback_decls callbacks callconv
                               = let ccl   = "__" ++ map toLower (genCcall callconv)
                                     decls = unlines $ concatMap (\(Callback n t ty _oty ann) -> 
                                                -- let x       = createCType $ strip ty
                                                let x       = createCType (annWorkingSetC ann) $ strip (translatePrimitive (annWorkingSet ann) t)
                                                    strip p = case p of
                                                                Exts.TyParen s -> strip s
                                                                _              -> p
                                                    restype = last x
                                                    rest    = case length x > 1 of
                                                               True  -> init x
                                                               False -> [" void "]
                                                    args    = intercalate ", " rest
                                                in ["// type " ++ n ++ " = " ++ mshowM 2 (strip t)
                                                   ,"typedef " ++ ccl ++ " " ++ restype ++ " (*" ++ n ++ "_t)(" ++ args ++ ");"]) callbacks 
                                 in if null callbacks
                                       then [] 
                                       else ["", "// Callback functions typedefs", decls]
-- | Inline a DataField definition by removing one layer of wrapping from it.    
inline' :: DataField -> [DataField]
inline' (Field _ _ _ _ x) = x
inline' _                 = []