-- | Generate C wrappers for haskell FFI functions
module ByteCode.Wrap(bcWrap) where

import Flags
import ByteCode.Type
import IntState
import Id
import ForeignCode
import Syntax(CallConv(..))
import SysDeps (trace)
import ByteCode.Write
import SysDeps (unpackPS)
import TokenId

-- | Generate C stub wrappers for FFI functions.  Writes generated C code
--   to the indicated file.
bcWrap :: IntState     -- ^ internal compiler state
       -> Flags        -- ^ compiler flags
       -> FileFlags    -- ^ information about the file to write
       -> BCModule     -- ^ the declarations from which to generate external wrappers
       -> IO ()

bcWrap state flags fileflags m =
    withDirectory (sWrapFile fileflags) (\s -> "Wrap"++s) (f "")
    where
    ds = bcmDecls m
    f = showString "#include <hsffi.h>\n\n" . catShows (map (wDecl state) ds) . (wInit state ds)

wDecl :: IntState -> BCDecl -> ShowS
wDecl state (External name pos arity cName callConv flags)
    | callConv /= "builtin" = undefined {- FIXME: !!!!!!!!
    wForeign cName' forn callConv
    where
    syms    = getSymbolTable state
    memo    = foreignMemo syms
    mode    = trace ("FIXME: wDecl mode ...") Imported
    forn    = toForeign syms memo callConv mode cName arity name
    cName'  = reverse $ takeWhile (/='&') $ reverse cName -}

wDecl state x                                              = id


wInit :: IntState -> [BCDecl] -> ShowS
wInit state ds =
    showString "\n\n/* autogenerated init function */\n" .
    showString "void init_" . showString initName . showString "(WrapRegisterFun reg, void* arg){\n" .
    catShows (map (wInitDecl state) ds) .
    showString "}\n"
    where
    initName = replace '.' '_' $ reverse $  unpackPS $ mrpsIS state

    replace a b xs = map (\x -> if x == a then b else x) xs


wInitDecl :: IntState -> BCDecl -> ShowS
wInitDecl state (External name pos arity cName callConv flags)
    | callConv /= "builtin" =
        showString "  reg(\"" . showString smod . showString "\", \"" . showString cName . showString "\", " . showString fname .
        showString ", arg);\n"
    where
    fname = if callConv == "primitive" then cName else "Wrap_" ++ cName
    (smod,sname) = splitQualified name
wInitDecl state x = id

wForeign :: String -> Foreign -> String -> ShowS
wForeign cname fr@(Foreign ie proto style mpath _ htok arity args res) callConv =
    wInclude mpath .
    (if proto then wProto style callConv cname args res else id) .
    if callConv /= "primitive"
     then
        (wHeader htok cname .
         wResDecl res .
         catShows ds .
         catShows rs .
         wCall style cname args res .
         wBoxResult res .
         wFooter)
     else id
    where
    (ds,rs) = unzip $ map wArgDecl [0..arity-1]

wInclude :: Maybe FilePath -> ShowS
wInclude Nothing  = id
wInclude (Just p) = showString "#include <" . showString p . showString ">\n\n"

wHeader :: TokenId -> String -> ShowS
wHeader name cName =
    showString "/* auto-generated wrapper for " . shows name . showString " */\n" .
    showString "Node* Wrap_" . showString cName . showString "(Node* node){\n" .
    showString "  Node* nResult = NULL;\n"

wFooter :: ShowS
wFooter =
    showString "  return nResult;\n" .
    showString "}\n\n"

wArgDecl :: Int -> (ShowS,ShowS)
wArgDecl n = (decl,remove)
    where
    decl   = showString "  Node* arg" . shows n . showString " = node->args[" . shows n . showString "];\n"
    remove = showString "  REMOVE_IND(arg" . shows n . showString ", Node*);\n"

wResDecl :: Res -> ShowS
wResDecl Unit = id
wResDecl res  = showString "  " . typeName res . showString " pResult;\n"

wProto :: Style -> String -> String -> [Arg] -> Res -> ShowS
wProto Ordinary callConv cname args res
    | callConv == "primitive" = showString "Node* " . showString cname . showString "(Node* node);\n\n"
    | otherwise                     = typeName res . showChar ' ' . showString cname .
                                      wCommaParens (map typeName args) . showString ";\n\n"
wProto CCast callConv cnaem args res = id

wCall :: Style -> String -> [Arg] -> Res -> ShowS
wCall Ordinary cname args res =
    wPResult res . showString cname . wArgUnboxes args . showString ";\n"
wCall CCast cname [arg] res =
    wPResult res . showChar '(' . typeName res . showChar ')' . wArgUnboxes [arg] . showString ";\n"

wPResult :: Arg -> ShowS
wPResult Unit = showString "  "
wPResult _    = showString "  pResult = "

wArgUnboxes :: [Arg] -> ShowS
wArgUnboxes args = wCommaParens $ map arg (zip args [0..])
    where
    arg (a,n) = showString "UNBOX_" . showString (boxName a) . showString "(arg" . shows n . showChar ')'

wCommaParens :: [ShowS] -> ShowS
wCommaParens xs = showChar '(' . interleave (showChar ',') xs . showChar ')'
    where
    interleave y [] = id
    interleave y xs = foldr1 (\x s -> x . y . s) xs

wBoxResult :: Res -> ShowS
wBoxResult Unit = showString "  nResult = NODE_UNIT;\n"
wBoxResult res = showString "  BOX_" . showString (boxName res) . showString "(nResult,pResult);\n"

boxName :: Arg -> String
boxName Int8 = "INT8"
boxName Int16 = "INT16"
boxName Int32 = "INT32"
boxName Int64 = "INT64"
boxName Word8 = "WORD8"
boxName Word16 = "WORD16"
boxName Word32 = "WORD32"
boxName Word64 = "WORD64"
boxName Int = "INT"
boxName Float = "FLOAT"
boxName Double = "DOUBLE"
boxName Char = "CHAR"
boxName Bool = "BOOL"
boxName Ptr = "PTR"
boxName (FunPtr _) = "FUN_PTR"
boxName StablePtr = "STABLE_PTR"
boxName ForeignPtr = "FOREIGN_PTR"
boxName Addr = "ADDR"
boxName ForeignObj = "FOREIGN_OBJ"
boxName PackedString = "STRING"
boxName Integer = "INTEGER"
boxName (HaskellFun _) = "HS_FUN"
boxName (Unknown _) = "UNKNOWN"
boxName Unit = "UNIT"

typeName :: Arg -> ShowS
typeName (FunPtr _) = showString "FunPtr"
typeName x          = cTypename x

--------------------------------------------------------------------------------------------------------

showId :: IntState -> Id -> ShowS
showId state i = showString $ strIS state i

catShows :: [ShowS] -> ShowS
catShows = foldr (.) id