module HSGen.FFI where
import Aux (apToLast)
import Control.Monad (liftM2)
import qualified Data.Text as T (Text, append, concat, cons, intercalate, pack, singleton, unwords)
import Data.Bits (Bits(..))
import Data.Default (Default(..))
import Data.Fixable (Fix(..), isFixed)
import Data.Text.Aux (addArrows, appendAfter, parens, showInt, textAp, unwords2, wrapText)
pragma :: T.Text
pragma = T.pack "{-# LANGUAGE ForeignFunctionInterface #-}\n"
typesImport :: [T.Text] -> T.Text
typesImport typeList = T.concat [T.pack "import Foreign.C.Types (", T.unwords typeList, T.pack ")\n"]
tlist :: [T.Text]
tlist = map T.pack ["CInt","CInt", "CULLong", "CSChar", "CInt"]
ioifyUnit :: T.Text -> T.Text
ioifyUnit = textAp "IO"
fixUnit :: T.Text -> T.Text
fixUnit = textAp "Fix"
ioifyTypeList :: [T.Text] -> [T.Text]
ioifyTypeList = apToLast ioifyUnit
fixInit :: [T.Text] -> T.Text
fixInit = addArrows . map fixUnit . init
wrapperLast :: [T.Text] -> T.Text
wrapperLast = textAp "Wrapper" . liftM2 unwords2 (textAp "FunPtr" . addArrows) (parens . last)
fixTypeList :: [T.Text] -> T.Text
fixTypeList = liftM2 (appendAfter (T.pack " -> ")) fixInit wrapperLast
functionImport :: T.Text -> T.Text -> T.Text -> T.Text
functionImport header name ftype = T.unwords [T.pack "foreign import ccall",
wrapText '\"' . T.concat $ [header, T.singleton ' ', name],
T.append (T.pack "c_") name,
T.pack "::",
ftype,
T.pack "\n"]
instance Bits a => Default a where
def = zeroBits
defUnfix :: Default a => Fix a -> a
defUnfix (Fixed x) = x
defUnfix Unfixed = def
importBits :: T.Text
importBits = T.pack "import Data.Bits (bit, xor, zeroBits)\n"
auxBoolToText :: Int -> T.Text
auxBoolToText pos = parens . T.concat $ [T.pack "if x", showInt pos, T.pack " then bit ", showInt (pos 1), T.pack " else zeroBits"]
mkTup :: Int -> T.Text
mkTup n = parens . T.intercalate (T.singleton ',') . map (T.cons 'x' . showInt) $ [1..n]
mkBoolToCUInt :: Int -> T.Text
mkBoolToCUInt n = T.concat [T.pack "boolToCUInt", showInt n, T.singleton ' ', mkTup n, T.pack " = ", T.intercalate (T.pack " `xor` ") . map auxBoolToText $ [1..n]]
mkBoolToCUIntName :: Int -> T.Text
mkBoolToCUIntName n = T.append (T.pack "boolToCUInt") (showInt n)
andIsFixed :: Int -> T.Text
andIsFixed = T.intercalate (T.pack " && ") . map (T.append (T.pack "isFixed x") . showInt) . enumFromTo 1
mkIsFixed :: Int -> T.Text
mkIsFixed n = T.concat [T.pack "isFixed", T.intercalate (T.pack " x") (showInt n : map showInt [1..n]), T.pack " = ", andIsFixed n, T.singleton '\n']
mkIsFixedName :: Int -> T.Text
mkIsFixedName n = T.append (T.pack "isFixed") (showInt n)