Foreign.hs

module System.Installer.Foreign
where

import Foreign
import Foreign.C
import System.Directory
import System.FilePath
import System.IO
import Data.Word
import qualified Data.ByteString as B

writeCHeaderFile :: Handle -> String -> IO ()
writeCHeaderFile outH name
    = do { hPutStrLn outH lenDeclFuncSig
         ; hPutStrLn outH arrayDeclFuncSig
         }
    where
      lenDeclFuncSig = "const int " ++ name ++ "_length ();"
      arrayDeclFuncSig = "const unsigned char* " ++ name ++ " ();"

writeCFile :: Handle -> String -> B.ByteString -> FilePath -> IO ()
writeCFile outH name content header
    = do { hPutStrLn outH includeLine
         ; hPutStrLn outH lenDecl
         ; hPutStrLn outH arrayDecl
         ; mapM_ writeWord (B.unpack content)
         ; hPutStrLn outH tailDecl
         ; hPutStrLn outH lenDeclFunc
         ; hPutStrLn outH arrayDeclFunc
         }
    where
      len = show . B.length $ content
      includeLine = "#include \"" ++ header ++ "\""
      lenDecl = "const int " ++ name ++ "_length_raw = " ++ len ++ ";"
      arrayDecl = "const unsigned char " ++ name ++
                  "_raw[" ++ len ++ "] = {"
      tailDecl = "};"
      lenDeclFunc = "const int " ++ name ++ "_length () { return " ++
                    name ++ "_length_raw" ++ "; }"
      arrayDeclFunc = "const unsigned char* " ++ name ++ " () { return " ++
                      name ++ "_raw" ++ "; }"
      writeWord :: Word8 -> IO ()
      writeWord wrd = hPutStrLn outH numTxt
          where
            numTxt = (show wrd) ++ ","

convertFileToCHeader :: FilePath -> String -> IO (FilePath)
convertFileToCHeader file clauseName
    = do { (tmpFileHPath, tmpFileHHdl) <- openBinaryTempFile "" leafNameH
         ; writeCHeaderFile tmpFileHHdl clauseName
         ; hClose tmpFileHHdl
         ; contentsB <- B.readFile file
         ; (tmpFileCPath, tmpFileCHdl) <- openBinaryTempFile "" leafNameC
         ; writeCFile tmpFileCHdl clauseName contentsB tmpFileHPath
         ; hClose tmpFileCHdl
         ; return tmpFileCPath
         }
    where
      leafName = takeFileName file
      leafNameNoExts = dropExtensions leafName
      leafNameH = addExtension leafNameNoExts "h"
      leafNameC = addExtension leafNameNoExts "c"

writeFromPtrToFile :: Ptr CUChar -> Int -> FilePath -> IO ()
writeFromPtrToFile ptr len filePath
    = do { outH <- openBinaryFile filePath WriteMode
         ; hPutBuf outH ptr len
         ; hClose outH
         }

writeFileData :: Ptr CUChar -> CInt -> String -> FilePath -> IO ()
writeFileData ptr len origName path
    = do { isDir <- doesDirectoryExist path
         ; let path' = if isDir then combine path origName else path
         ; writeFromPtrToFile ptr (fromIntegral len) path'
         }