module Haste.Foreign (
FFI, Pack (..), Unpack (..), 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 Pack a where
pack :: Unpacked -> a
pack = unsafePack
class Unpack a where
unpack :: a -> Unpacked
unpack = unsafeUnpack
class (Pack a, Unpack a) => Marshal a
instance (Pack a, Unpack a) => Marshal a
instance Pack Float
instance Pack Double
instance Pack JSAny
instance Pack JSString where
pack = jsString . unsafePack
instance Pack Int where
pack x = convert (unsafePack x :: Double)
instance Pack Int8 where
pack x = convert (unsafePack x :: Double)
instance Pack Int16 where
pack x = convert (unsafePack x :: Double)
instance Pack Int32 where
pack x = convert (unsafePack x :: Double)
instance Pack Word where
pack x = convert (unsafePack x :: Double)
instance Pack Word8 where
pack x = convert (unsafePack x :: Double)
instance Pack Word16 where
pack x = convert (unsafePack x :: Double)
instance Pack Word32 where
pack x = convert (unsafePack x :: Double)
instance Pack () where
pack _ = ()
instance Pack String where
pack = fromJSStr . pack
instance Pack Unpacked where
pack = id
instance Pack (Opaque a) where
pack = Opaque
instance Pack Bool where
pack x = if pack x > (0 :: Double) then True else False
instance Pack a => Pack [a] where
pack arr = map pack . fromOpaque $ arr2lst arr 0
instance Pack a => Pack (Maybe a) where
pack x = if isNull x then Nothing else Just (pack x)
instance (Pack a, Pack b) => Pack (a, b) where
pack x = case pack x of [a, b] -> (pack a, pack b)
instance (Pack a, Pack b, Pack c) => Pack (a, b, c) where
pack x = case pack x of [a, b, c] -> (pack a, pack b, pack c)
instance (Pack a, Pack b, Pack c, Pack d) =>
Pack (a, b, c, d) where
pack x = case pack x of [a, b, c, d] -> (pack a, pack b, pack c, pack d)
instance (Pack a, Pack b, Pack c, Pack d, Pack e) =>
Pack (a, b, c, d, e) where
pack x = case pack x of [a,b,c,d,e] -> (pack a, pack b, pack c, pack d, pack e)
instance (Pack a, Pack b, Pack c, Pack d, Pack e,
Pack f) => Pack (a, b, c, d, e, f) where
pack x = case pack x of
[a, b, c, d, e, f] -> (pack a, pack b, pack c, pack d, pack e, pack f)
instance (Pack a, Pack b, Pack c, Pack d, Pack e,
Pack f, Pack g) => Pack (a, b, c, d, e, f, g) where
pack x = case pack x of
[a, b, c, d, e, f, g] -> (pack a,pack b,pack c,pack d,pack e,pack f,pack g)
instance (Pack a, Pack b, Pack c, Pack d, Pack e,
Pack f, Pack g, Pack h) =>
Pack (a, b, c, d, e, f, g, h) where
pack x = case pack x of
[a, b, c, d, e, f, g, h] -> (pack a, pack b, pack c, pack d, pack e,
pack f, pack g, pack h)
instance (Pack a, Pack b, Pack c, Pack d, Pack e,
Pack f, Pack g, Pack h, Pack i) =>
Pack (a, b, c, d, e, f, g, h, i) where
pack x = case pack x of
[a, b, c, d, e, f, g, h, i] -> (pack a, pack b, pack c, pack d, pack e,
pack f, pack g, pack h, pack i)
instance (Pack a, Pack b, Pack c, Pack d, Pack e,
Pack f, Pack g, Pack h, Pack i, Pack j) =>
Pack (a, b, c, d, e, f, g, h, i, j) where
pack x = case pack x of
[a, b, c, d, e, f, g, h, i, j] -> (pack a, pack b, pack c, pack d, pack e,
pack f, pack g, pack h, pack i, pack j)
instance Unpack Float
instance Unpack Double
instance Unpack JSAny
instance Unpack JSString
instance Unpack Int
instance Unpack Int8
instance Unpack Int16
instance Unpack Int32
instance Unpack Word
instance Unpack Word8
instance Unpack Word16
instance Unpack Word32
instance Unpack () where
unpack _ = unpack (0 :: Double)
instance Unpack String where
unpack = unpack . toJSStr
instance Unpack Unpacked where
unpack = id
instance Unpack (Opaque a) where
unpack (Opaque x) = x
instance Unpack Bool where
unpack True = jsTrue
unpack False = jsFalse
instance Unpack a => Unpack [a] where
unpack = lst2arr . toOpaque . map unpack
instance Unpack a => Unpack (Maybe a) where
unpack Nothing = jsNull
unpack (Just x) = unpack x
instance (Unpack a, Unpack b) => Unpack (a, b) where
unpack (a, b) = unpack [unpack a, unpack b]
instance (Unpack a, Unpack b, Unpack c) => Unpack (a, b, c) where
unpack (a, b, c) = unpack [unpack a, unpack b, unpack c]
instance (Unpack a, Unpack b, Unpack c, Unpack d) =>
Unpack (a, b, c, d) where
unpack (a, b, c, d) = unpack [unpack a, unpack b, unpack c, unpack d]
instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e) =>
Unpack (a, b, c, d, e) where
unpack (a, b, c, d, e) = unpack [unpack a,unpack b,unpack c,unpack d,unpack e]
instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,
Unpack f) => Unpack (a, b, c, d, e, f) where
unpack (a, b, c, d, e, f) =
unpack [unpack a, unpack b, unpack c, unpack d, unpack e, unpack f]
instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,
Unpack f, Unpack g) => Unpack (a, b, c, d, e, f, g) where
unpack (a, b, c, d, e, f, g) =
unpack [unpack a,unpack b,unpack c,unpack d,unpack e,unpack f,unpack g]
instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,
Unpack f, Unpack g, Unpack h) =>
Unpack (a, b, c, d, e, f, g, h) where
unpack (a, b, c, d, e, f, g, h) =
unpack [unpack a, unpack b, unpack c, unpack d, unpack e,
unpack f, unpack g, unpack h]
instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,
Unpack f, Unpack g, Unpack h, Unpack i) =>
Unpack (a, b, c, d, e, f, g, h, i) where
unpack (a, b, c, d, e, f, g, h, i) =
unpack [unpack a, unpack b, unpack c, unpack d, unpack e,
unpack f, unpack g, unpack h, unpack i]
instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,
Unpack f, Unpack g, Unpack h, Unpack i, Unpack j) =>
Unpack (a, b, c, d, e, f, g, h, i, j) where
unpack (a, b, c, d, e, f, g, h, i, j) =
unpack [unpack a, unpack b, unpack c, unpack d, unpack e,
unpack f, unpack g, unpack h, unpack i, unpack j]
lst2arr :: Opaque [Unpacked] -> Unpacked
lst2arr = unsafePerformIO . ffi "lst2arr"
arr2lst :: Unpacked -> Int -> Opaque [Unpacked]
arr2lst arr ix = unsafePerformIO $ ffi "arr2lst" arr ix
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
instance Pack a => FFI (IO a) where
type T (IO a) = IO Unpacked
unpackify = fmap pack
instance (Unpack a, FFI b) => FFI (a -> b) where
type T (a -> b) = Unpacked -> T b
unpackify f x = unpackify (f $! unpack x)
class IOFun a where
type X a
packify :: a -> X a
instance Unpack a => IOFun (IO a) where
type X (IO a) = Unpacked
packify = unsafePerformIO . unpack' . toOpaque . fmap unpack
where
unpack' :: Opaque (IO a) -> IO Unpacked
unpack' =
ffi (toJSStr $ "(function(f) {" ++
" return (function() {" ++
" var args=Array.prototype.slice.call(arguments,0);"++
" args.push(0);" ++
" return E(B(A(f, args)));" ++
" });" ++
"})")
instance (Pack a, IOFun b) => IOFun (a -> b) where
type X (a -> b) = Unpacked -> X b
packify f = \x -> packify (f $! pack x)
instance Unpack a => Unpack (IO a) where
unpack = packify
instance (IOFun (a -> b)) => Unpack (a -> b) where
unpack = unsafeCoerce . packify
ffi :: FFI a => JSString -> a
ffi = unpackify . unsafeEval
export :: Unpack a => JSString -> a -> IO ()
export = ffi "(function(s,f){Haste[s] = 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