module Haste.Any (
ToAny (..), FromAny (..), Generic, JSAny (..),
Opaque, toOpaque, fromOpaque,
nullValue, toObject, has, get, index
) where
import GHC.Generics
import Haste.Prim
import Haste.JSType
import Data.Int
import Data.Word
import Unsafe.Coerce
import Control.Applicative
#ifdef __HASTE__
foreign import ccall __lst2arr :: Ptr [a] -> JSAny
foreign import ccall __arr2lst :: Int -> JSAny -> Ptr [a]
foreign import ccall "String" jsString :: JSAny -> JSString
foreign import ccall "Number" jsNumber :: JSAny -> Double
foreign import ccall "__jsNull" jsNull :: JSAny
foreign import ccall "__jsTrue" jsTrue :: JSAny
foreign import ccall "__jsFalse" jsFalse :: JSAny
foreign import ccall __new :: IO JSAny
foreign import ccall __set :: JSAny -> JSString -> JSAny -> IO ()
foreign import ccall __get :: JSAny -> JSString -> IO JSAny
foreign import ccall __has :: JSAny -> JSString -> IO Bool
#else
__new :: IO JSAny
__new = return undefined
__get :: JSAny -> JSString -> IO JSAny
__get _ _ = return undefined
__set :: JSAny -> JSString -> JSAny -> IO ()
__set _ _ _ = return ()
__has :: JSAny -> JSString -> IO Bool
__has _ _ = return False
__lst2arr :: Ptr [a] -> JSAny
__lst2arr _ = undefined
__arr2lst :: Int -> JSAny -> Ptr [a]
__arr2lst _ _ = undefined
jsString :: JSAny -> JSString
jsString _ = undefined
jsNumber :: JSAny -> Double
jsNumber _ = undefined
jsNull, jsTrue, jsFalse :: JSAny
jsNull = undefined
jsTrue = undefined
jsFalse = undefined
#endif
nullValue :: JSAny
nullValue = jsNull
toObject :: [(JSString, JSAny)] -> JSAny
toObject ps = veryUnsafePerformIO $ do
o <- __new
mapM_ (uncurry $ __set o) ps
return o
get :: FromAny a => JSAny -> JSString -> IO a
get o k = __get o k >>= fromAny
index :: FromAny a => JSAny -> Int -> IO a
index o k = __get o (unsafeCoerce k) >>= fromAny
has :: JSAny -> JSString -> IO Bool
has = __has
class ToAny a where
toAny :: a -> JSAny
default toAny :: (GToAny (Rep a), Generic a) => a -> JSAny
toAny x =
case gToAny False g of
Tree x' -> toObject x'
One x' -> if isEnum g then x' else toAny [x']
List x' -> toAny x'
where g = from x
listToAny :: [a] -> JSAny
listToAny = __lst2arr . toPtr . map toAny
class FromAny a where
fromAny :: JSAny -> IO a
listFromAny :: JSAny -> IO [a]
listFromAny = mapM fromAny . fromPtr . __arr2lst 0
newtype Opaque a = Opaque {fromOpaque :: a}
toOpaque :: a -> Opaque a
toOpaque = Opaque
instance ToAny JSAny where toAny = unsafeCoerce
instance ToAny (Ptr a) where toAny = unsafeCoerce
instance ToAny JSString where toAny = unsafeCoerce
instance ToAny Int where toAny = unsafeCoerce
instance ToAny Int8 where toAny = unsafeCoerce
instance ToAny Int16 where toAny = unsafeCoerce
instance ToAny Int32 where toAny = unsafeCoerce
instance ToAny Word where toAny = unsafeCoerce
instance ToAny Word8 where toAny = unsafeCoerce
instance ToAny Word16 where toAny = unsafeCoerce
instance ToAny Word32 where toAny = unsafeCoerce
instance ToAny Float where toAny = unsafeCoerce
instance ToAny Double where toAny = unsafeCoerce
instance ToAny Char where
toAny = unsafeCoerce
listToAny = toAny . toJSStr
instance ToAny () where
toAny _ = jsNull
instance ToAny (Opaque a) where
toAny (Opaque x) = unsafeCoerce $ toPtr x
instance ToAny Bool where
toAny True = jsTrue
toAny False = jsFalse
instance ToAny a => ToAny [a] where
toAny = listToAny
instance ToAny a => ToAny (Maybe a) where
toAny Nothing = jsNull
toAny (Just x) = toAny x
instance (ToAny a, ToAny b) => ToAny (a, b) where
toAny (a, b) = toAny [toAny a, toAny b]
instance (ToAny a, ToAny b, ToAny c) => ToAny (a, b, c) where
toAny (a, b, c) = toAny [toAny a, toAny b, toAny c]
instance (ToAny a, ToAny b, ToAny c, ToAny d) =>
ToAny (a, b, c, d) where
toAny (a, b, c, d) = toAny [toAny a, toAny b, toAny c, toAny d]
instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e) =>
ToAny (a, b, c, d, e) where
toAny (a, b, c, d, e) = toAny [toAny a,toAny b,toAny c,toAny d,toAny e]
instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e,
ToAny f) => ToAny (a, b, c, d, e, f) where
toAny (a, b, c, d, e, f) =
toAny [toAny a, toAny b, toAny c, toAny d, toAny e, toAny f]
instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e,
ToAny f, ToAny g) => ToAny (a, b, c, d, e, f, g) where
toAny (a, b, c, d, e, f, g) =
toAny [toAny a,toAny b,toAny c,toAny d,toAny e,toAny f,toAny g]
instance FromAny JSAny where
fromAny x = return (unsafeCoerce x)
instance FromAny (Ptr a) where
fromAny x = return (unsafeCoerce x)
instance FromAny JSString where
fromAny x = return (jsString x)
instance FromAny Int where
fromAny x = return (convert (jsNumber x))
instance FromAny Int8 where
fromAny x = return (convert (jsNumber x))
instance FromAny Int16 where
fromAny x = return (convert (jsNumber x))
instance FromAny Int32 where
fromAny x = return (convert (jsNumber x))
instance FromAny Word where
fromAny x = return (convert (jsNumber x))
instance FromAny Word8 where
fromAny x = return (convert (jsNumber x))
instance FromAny Word16 where
fromAny x = return (convert (jsNumber x))
instance FromAny Word32 where
fromAny x = return (convert (jsNumber x))
instance FromAny Float where
fromAny x = return (unsafeCoerce (jsNumber x))
instance FromAny Double where
fromAny x = return (jsNumber x)
instance FromAny Char where
fromAny x = return (unsafeCoerce (jsNumber x))
listFromAny x = fromJSStr <$> fromAny x
instance FromAny () where
fromAny _ = return ()
instance FromAny (Opaque a) where
fromAny x = Opaque . fromPtr <$> fromAny x
instance FromAny Bool where
fromAny x | x == jsTrue = return True
| otherwise = return False
instance FromAny a => FromAny [a] where
fromAny = listFromAny
instance FromAny a => FromAny (Maybe a) where
fromAny x | x == jsNull = return Nothing
| otherwise = Just <$> fromAny x
instance (FromAny a, FromAny b) => FromAny (a, b) where
fromAny x = do
[a,b] <- fromAny x
(,) <$> fromAny a <*> fromAny b
instance (FromAny a, FromAny b, FromAny c) => FromAny (a, b, c) where
fromAny x = do
[a,b,c] <- fromAny x
(,,) <$> fromAny a <*> fromAny b <*> fromAny c
instance (FromAny a, FromAny b, FromAny c, FromAny d) =>
FromAny (a, b, c, d) where
fromAny x = do
[a,b,c,d] <- fromAny x
(,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d
instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e) =>
FromAny (a, b, c, d, e) where
fromAny x = do
[a,b,c,d,e] <- fromAny x
(,,,,) <$> fromAny a <*> fromAny b <*> fromAny c
<*> fromAny d <*> fromAny e
instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e, FromAny f) =>
FromAny (a, b, c, d, e, f) where
fromAny x = do
[a,b,c,d,e,f] <- fromAny x
(,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c
<*> fromAny d <*> fromAny e <*> fromAny f
instance (FromAny a, FromAny b, FromAny c, FromAny d,
FromAny e, FromAny f, FromAny g) =>
FromAny (a, b, c, d, e, f, g) where
fromAny x = do
[a,b,c,d,e,f,g] <- fromAny x
(,,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d
<*> fromAny e <*> fromAny f <*> fromAny g
data Value = One !JSAny | List ![JSAny] | Tree ![(JSString, JSAny)]
class GToAny f where
gToAny :: Bool -> f a -> Value
isEnum :: f a -> Bool
instance GToAny U1 where
gToAny _ U1 = error "U1: unpossible!"
isEnum _ = True
instance ToAny a => GToAny (K1 i a) where
gToAny _ (K1 x) = One (toAny x)
isEnum _ = False
instance (Selector c, GToAny a) => GToAny (M1 S c a) where
gToAny mcs (M1 x) = do
case name of
"" -> One value
_ -> Tree [(name, value)]
where name = toJSStr (selName (undefined :: M1 S c a ()))
value =
case gToAny mcs x of
Tree x' -> toObject x'
One x' -> toAny x'
List x' -> toAny x'
isEnum _ = isEnum (undefined :: a ())
instance Constructor c => GToAny (M1 C c U1) where
gToAny _ _ = One (toAny $ conName (undefined :: M1 C c U1 ()))
isEnum _ = True
instance (Constructor c, GToAny a) => GToAny (M1 C c a) where
gToAny many_constrs (M1 x)
| many_constrs =
case args of
Tree args' -> Tree (("$tag", toAny tag) : args')
One arg -> Tree [("$tag", toAny tag), ("$data", arg)]
List args' -> Tree [("$tag", toAny tag), ("$data", toAny args')]
| otherwise =
args
where
tag = conName (undefined :: M1 C c a ())
args = gToAny many_constrs x
isEnum _ = isEnum (undefined :: a ())
instance GToAny a => GToAny (M1 D c a) where
gToAny cs (M1 x) = gToAny cs x
isEnum _ = isEnum (undefined :: a ())
instance (GToAny a, GToAny b) => GToAny (a :*: b) where
gToAny cs (a :*: b) =
case (gToAny cs a, gToAny cs b) of
(One l, One r) -> List [l, r]
(One x, List xs) -> List (x:xs)
(List xs, One x) -> List (xs ++ [x])
(List l, List r) -> List (l ++ r)
(Tree l, Tree r) -> Tree (l ++ r)
(_, _) -> error "Tree :*: non-tree!"
isEnum _ = False
instance (GToAny a, GToAny b) => GToAny (a :+: b) where
gToAny _ (L1 x) = gToAny True x
gToAny _ (R1 x) = gToAny True x
isEnum _ = isEnum (undefined :: a ()) && isEnum (undefined :: b ())