-----------------------------------------------------------------------------
-- |
-- 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.Hs2lib

import WinDll.Structs.C
import qualified WinDll.Structs.C as 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 ++ 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 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 natDefs manualdef)
    
-- | Generate the export list from a list of defined FFI Export systems
createLocalExports :: Ann -> HaskellExport -> [String]
createLocalExports ann (HaskellExport clp _ (Export _ a t _ modnm)) =
        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 _ modnm)->["  _" ++ a ++ "@" ++ getSize ann t ++ " = " ++ a ++ "@" ++ getSize ann t," " ++  a ++ "@" ++ getSize ann t]) funcs
          CCall   -> map (\(Export _ a t _ modnm)->"   " ++ a) funcs          
   
-- | Return the size of a specified type      
getSize ann x = let types = createCType (annWorkingSetC ann) x
                    args  = init types
                    sizes = map (rnd . lookupSize (annWorkingSetCSize ann)) args
                    rnd m = let i = m + 3 in (i - (i `mod` 4)) -- round up to nearest mutiple of 4
                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 _ modnm)->
                           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"
                                     ,""
                                     ,"#if _WIN64 || __amd64__"
                                     ,"#define CALLTYPE(x) __declspec(dllimport) x"
                                     ,"#else"
                                     ,"#define CALLTYPE(x) __declspec(dllimport) x __" ++ conven
                                     ,"#endif"
                                     ,""
                                     ,"#else"
                                     ,""
                                     ,"#if _WIN64 || __amd64__"
                                     ,"#define CALLTYPE(x) x"
                                     ,"#else"
                                     ,"#define CALLTYPE(x) x __attribute__((__" ++ conven ++ "__))"
                                     ,"#endif"
                                     ,""
                                     ,"#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 ft _) = 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") C.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) C.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 ft 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)) C.Normal (Just (antName x))
                                  size = Value VAlue (lpc (Exts.TyCon $ Exts.UnQual $ Exts.Ident "Int")) C.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 ft _) = Value Struct name C.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]