Hs2lib-0.4.8: WinDll/CodeGen/C.hs
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- Generates the needed C code needed by the FFI Calls.
--
-----------------------------------------------------------------------------
module WinDll.CodeGen.C where
import WinDll.CodeGen.Lookup
import WinDll.Structs.Structures
import WinDll.Utils.Feedback
import WinDll.Builder
import WinDll.Identifier
import WinDll.Session
import WinDll.Structs.C
import WinDll.Structs.MShow.MShow
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
-- | For internal use only.
type CodeGen = CDataType
-- | Write out the main header file and the definition file for the exports
writeCFiles :: Component
writeCFiles = do inform _normal "Generating C/C++ files for pipeline"
modInfo <- generateMain
session <- get
ann <- makeSessionAnn
let name = namespace session
symb = native_symbols 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 export definition file"
extra_defs <- liftIO $ fmap (fmap (" "++)) $ mapM readFile symb
createComponent "exports.def" ((return.unlines) (generateExports ann callconv name exports
++ concatMap (createLocalExports ann) defs
++ extra_defs))
inform _detail "Creating C/C++ structures header file"
createComponent (name++".h") (return $ mkHeader ++ (mshow $ generateHeaderFile ann callconv callbacks datatypes))
inform _detail "Creating C/C++ function include header file"
createComponent (name++"_FFI.h") (generateFFIHeader ann (call session) name exports natives manualdef)
-- | Generate the export list from a list of defined FFI Export systems
createLocalExports :: Ann -> HaskellExport -> [String]
createLocalExports ann (HaskellExport clp _ (Export _ a t _)) =
case clp of
StdCall -> [" _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++ a ++ "@" ++ getSize ann t]
CCall -> [" " ++ a]
-- | Generate the export list from the list of functions.
generateExports :: Ann -> CallConvention -> String -> [Export] -> [String]
generateExports ann clp name funcs = ("LIBRARY " ++ name) : "EXPORTS" :
case clp of
StdCall -> concatMap (\(Export _ a t _)->[" _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++ a ++ "@" ++ getSize ann t]) funcs
CCall -> map (\(Export _ a t _)->" " ++ a) funcs
-- | Return the size of a specified type
getSize ann x = let types = createCType (annWorkingSetC ann) x
args = init types
sizes = map (lookupSize (annWorkingSetCSize ann)) args
in show (sum sizes)
-- | Generate the C extern list from the list of functions.
generateFFIHeader :: Ann -> CallConvention -> String -> [Export] -> [HaskellExport] -> [HaskellExport] -> Exec String
generateFFIHeader ann clp name funcs natives defs
= do session <- get
list <- getDocumentationInfo
-- declare exported functions
let types = concatMap (\(Export _ n t _)->
let x = createCType (annWorkingSetC ann) t -- genAndLookupC 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 = let value = intercalate ", " (zipWith (\a b->a++" "++b) rest names)
in if null value then " void " else value
in unlines $ [[],"// " ++ n ++ " ::" ++ (resp $ mshowM 2 t)]
++ maybe [] id (fmap (\x->map ("// "++) (description x)) $ M.lookup n list) ++
["extern CALLTYPE(" ++ restype ++ ") " ++ n ++ " (" ++ args ++ ");"
])
-- re-export previously reclared export statements
native_declares = let decls = types (map (\(HaskellExport clp _ e) -> e) natives)
in if null natives
then ""
else unlines ["// Preserved export statements", decls]
-- declare the runtime system control functions (start & stop)
rts_controldecl = let decls = types (map (\(HaskellExport _ _ e) -> e) defs)
in if null defs
then ""
else unlines ["// Runtime control methods", tail decls]
-- declare the calling convention
mkMacros conven = unlines ["#ifdef _MSC_VER"
,"#define CALLTYPE(x) __declspec(dllimport) x __" ++ conven
,"#else"
,"#define CALLTYPE(x) x __attribute__((__" ++ conven ++ "__))"
,"#endif"]
return $ unlines $ mkHeader
: ("#include \"" ++ name ++ ".h\"")
: ""
: mkMacros (map toLower (genCcall clp))
: "#ifdef __cplusplus"
: "extern \"C\" {"
: "#endif"
: rts_controldecl
: types funcs
: native_declares
: ["#ifdef __cplusplus"
,"}"
,"#endif"]
-- | Create the enum list from the Datatype if required.
-- No enum is needed for newtypes or when only 1 constructor is available for the Data instance
generateEnum :: DataType -> Maybe DataEnum
generateEnum (DataType name _ t _) = guard (length t > 1) >> return (mkEnum name t)
generateEnum (NewType name _ t _) = Nothing
-- | Create an enum list from a list of Constructors
mkEnum name t = DataEnum name (map enum t)
where enum (Constr name _) = filter isAlphaNum name --filter isAlpha (map toLower name)
-- | Generate complete file from given structures
generateHeaderFile :: Ann -> CallConvention -> [Callback] -> DataTypes -> C
generateHeaderFile ann cc cb = (\(a,b,c)->C d_includes cc cb (join a) (join b) (join c)) . unzip3 . map (generateCCode (lookupC (annWorkingSetC ann)))
where d_includes = [LibInclude "string.h"
,LibInclude "stdint.h"
,LocalInclude "Instances.h"
,LocalInclude "Tuples.h"
]
-- | Create the Structures and Unions required for the C code along with the enums if needed.
generateCCode :: LookupType -> DataType -> ([DataEnum],[DataField],[DataField])
generateCCode lc d = (maybeToList (generateEnum d), nub (generateStructs d), generateTopLevelStruct d)
where
generateStructs :: DataType -> [DataField] -- ("struct " ++ name ++ ";") :
-- generateStructs (DataType name e [_] _) = [Forward Struct name] -- treat datastructures with only 1 constructor as a newtype
generateStructs (DataType name e t _) = Forward Struct name : map (\(Constr n _)->Forward Struct n) t
generateStructs (NewType name e _ _) = [Forward Struct name]
--generateStructs (NewType name e t _) = generateStructs (DataType name e [t] NoTag)
generateTopLevelStruct :: DataType -> [DataField]
generateTopLevelStruct (DataType name e t _) =
case length t `compare` 1 of
GT -> join [wrapStruct Struct name entries, mkStructs e t, mkUnion name t]
LT -> join [wrapStruct Struct name [Value Union (name++"Union") Normal (Just "elt")],mkStructs e t,mkUnion name t]
EQ -> generateTopLevelStruct (NewType name e (head t) NoTag) -- treat as newtype.
where entries = [Value ENum ("List"++name) Normal (Just "tag"),Value Union (name++"Union") Pointer (Just "elt")]
generateTopLevelStruct (NewType name e t NoTag) = wrapStruct Struct name (concatMap inline' (mkStruct e t))
mkStructs :: TypeNames -> [DataType] -> [DataField]
mkStructs types constrs = concatMap (mkStruct types) constrs
mkStruct :: TypeNames -> DataType -> [DataField]
mkStruct types (Constr name values) = wrapStruct Struct name (concatMap mkLine values)
where lpc = mshowM 1 . lc types -- TODO: rewrite this to support type applied types in datatypes
mkLine x = let ann = antAnn x
base = Value VAlue (lpc (antType x)) Normal (Just (antName x))
size = Value VAlue (lpc (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int")) Normal (Just (antName x ++ "_Size"))
in case annArrayIsList ann of
True -> [base, size]
False -> [base]
mkStruct _ _ = error "mkStruct can only be called with a the 'Const' argument."
mkUnion :: Name -> DataTypes -> [DataField]
mkUnion name types = wrapStruct Union (name++"Union") (map mkEntry types)
-- name ++ "* " for pointers
where mkEntry (Constr name _) = Value Struct name Normal (Just $ "var_" ++ filter isAlphaNum name ) --(map toLower name))
wrapStruct :: CodeGen -> String -> [DataField] -> [DataField]
wrapStruct Struct n l = [Field NormalDef Struct n [] l]-- TypeDef Struct n n l]
wrapStruct Union n l = [Field NormalDef Union n [] l]