module Haste.Foreign (
FFI, Marshal (..), Unpacked, Opaque, ffi, export, toOpaque, fromOpaque
) where
import Haste.Prim
import Haste.JSType
import Data.Word
import Data.Int
import System.IO.Unsafe
import Unsafe.Coerce
#ifdef __HASTE__
foreign import ccall eval :: JSString -> IO (Ptr a)
foreign import ccall "String" jsString :: Double -> JSString
#else
eval :: JSString -> IO (Ptr a)
eval = error "Tried to use eval on server side!"
jsString :: Double -> JSString
jsString = error "Tried to use jsString on server side!"
#endif
data Unpacked = A | B
newtype Opaque a = Opaque Unpacked
toOpaque :: a -> Opaque a
toOpaque = unsafeCoerce
fromOpaque :: Opaque a -> a
fromOpaque = unsafeCoerce
data Dummy = Dummy Unpacked
class Marshal a where
pack :: Unpacked -> a
pack = unsafePack
unpack :: a -> Unpacked
unpack = unsafeUnpack
instance Marshal Float
instance Marshal Double
instance Marshal JSString where
pack = jsString . unsafePack
instance Marshal Int where
pack x = convert (unsafePack x :: Double)
instance Marshal Int8 where
pack x = convert (unsafePack x :: Double)
instance Marshal Int16 where
pack x = convert (unsafePack x :: Double)
instance Marshal Int32 where
pack x = convert (unsafePack x :: Double)
instance Marshal Word where
pack x = convert (unsafePack x :: Double)
instance Marshal Word8 where
pack x = convert (unsafePack x :: Double)
instance Marshal Word16 where
pack x = convert (unsafePack x :: Double)
instance Marshal Word32 where
pack x = convert (unsafePack x :: Double)
instance Marshal () where
pack _ = ()
unpack _ = unpack (0 :: Double)
instance Marshal String where
pack = fromJSStr . pack
unpack = unpack . toJSStr
instance Marshal Unpacked where
pack = id
unpack = id
instance Marshal (Opaque a) where
pack = Opaque
unpack (Opaque x) = x
instance Marshal Bool where
unpack True = jsTrue
unpack False = jsFalse
pack x = if pack x > (0 :: Double) then True else False
instance Marshal a => Marshal [a] where
unpack = lst2arr . toOpaque . map unpack
pack arr = map pack . fromOpaque $ arr2lst arr 0
lst2arr :: Opaque [Unpacked] -> Unpacked
lst2arr = unsafePerformIO . ffi "lst2arr"
arr2lst :: Unpacked -> Int -> Opaque [Unpacked]
arr2lst arr ix = unsafePerformIO $ ffi "lst2arr" arr ix
instance Marshal a => Marshal (Maybe a) where
unpack Nothing = jsNull
unpack (Just x) = unpack x
pack x = if isNull x then Nothing else Just (pack x)
jsNull, jsTrue, jsFalse :: Unpacked
jsTrue = unsafePerformIO $ ffi "true"
jsFalse = unsafePerformIO $ ffi "false"
jsNull = unsafePerformIO $ ffi "null"
isNull :: Unpacked -> Bool
isNull = unsafePerformIO . ffi "(function(x) {return x === null;})"
class FFI a where
type T a
unpackify :: T a -> a
packify :: a -> a
instance Marshal a => FFI (IO a) where
type T (IO a) = IO Unpacked
unpackify = fmap pack
packify m = fmap (unsafeCoerce . unpack) m
instance (Marshal a, FFI b) => FFI (a -> b) where
type T (a -> b) = Unpacked -> T b
unpackify f x = unpackify (f $! unpack x)
packify f x = packify (f $! pack (unsafeCoerce x))
ffi :: FFI a => JSString -> a
ffi = unpackify . unsafeEval
export :: FFI a => JSString -> a -> IO ()
export name f =
ffi (toJSStr $ "(function(s, f) {" ++
" Haste[s] = function() {" ++
" var args = Array.prototype.slice.call(arguments,0);" ++
" args.push(0);" ++
" return E(A(f, args));" ++
" };" ++
" return 0;" ++
"})") name f'
where
f' :: Unpacked
f' = unsafeCoerce $! packify f
unsafeUnpack :: a -> Unpacked
unsafeUnpack x =
case unsafeCoerce x of
Dummy x' -> x'
unsafePack :: Unpacked -> a
unsafePack = unsafeCoerce . Dummy
unsafeEval :: JSString -> a
unsafeEval s = unsafePerformIO $ do
x <- eval s
return $ fromPtr x