-----------------------------------------------------------------------------
-- |
-- 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]