content: -- For the FFI
  {-# LANGUAGE ForeignFunctionInterface, PatternGuards, CPP, BangPatterns #-}
  
  -- For generic default instances
  {-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances,
               FlexibleContexts, OverloadedStrings, DefaultSignatures #-}
  
  -- For less annoying instances
  {-# LANGUAGE TupleSections #-}
  
  -- | Converting to/from JS-native data.
  module Haste.Prim.Any (
      ToAny (..), FromAny (..), Generic, JSAny (..),
      Opaque, toOpaque, fromOpaque,
      nullValue, toObject, has, get, index, isUndefined
    ) where
  import GHC.Generics
  import Control.Exception
  import Haste.Prim
  import Haste.Prim.JSType
  import Data.Int
  import Data.Word
  import Unsafe.Coerce
  import System.IO.Unsafe -- for toObject
  
  #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 "__isUndef" isUndefined :: JSAny -> Bool
  foreign import ccall __jsNull :: IO 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 :: IO JSAny
  __jsNull = undefined
  isUndefined :: JSAny -> Bool
  isUndefined = undefined
  #endif
  
  {-# NOINLINE jsNull #-}
  jsNull :: JSAny
  jsNull = unsafePerformIO __jsNull
  
  {-
    For theoretical purposes, imagine the following here:
    foreign import ccall __intToAny :: Int -> JSAny
    ...
    In practice, however, we use unsafeCoerce for that to avoid the roundtrip.
  -}
  
  -- | The JS value null.
  nullValue :: JSAny
  nullValue = jsNull
  
  -- | Build a new JS object from a list of key:value pairs.
  toObject :: [(JSString, JSAny)] -> JSAny
  toObject ps = veryUnsafePerformIO $ do
    o <- __new
    mapM_ (uncurry $ __set o) ps
    return o
  
  -- | Read a member from a JS object. Throws an error if the member can not be
  --   marshalled into a value of type @a@.
  {-# INLINE get #-}
  get :: FromAny a => JSAny -> JSString -> IO a
  get o k = __get o k >>= fromAny
  
  {-# INLINE index #-}
  -- | Read an element from a JS array. Throws an error if the member can not be
  --   marshalled into a value of type @a@.
  index :: FromAny a => JSAny -> Int -> IO a
  index o k = __get o (unsafeCoerce k) >>= fromAny
  
  -- | Check if a JS object has a particular member.
  {-# INLINE has #-}
  has :: JSAny -> JSString -> IO Bool
  has = __has
  
  -- | Any type that can be converted into a JavaScript value.
  class ToAny a where
    -- | Build a JS object from a Haskell value.
    --
    --   The default instance creates an object from any type that derives
    --   'Generic' according to the following rules:
    --
    --   * Records turn into plain JS objects, with record names as field names.
    --
    --   * Non-record product types turn into objects containing a @$data@ field
    --     which contains all of the constructor's unnamed fields.
    --
    --   * Values of enum types turn into strings matching their constructors.
    --
    --   * Non-enum types with more than one constructor gain an extra field,
    --     @$tag@, which contains the name of the constructor used to create the
    --     object.
    --
    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
  
  -- | Any type that can be converted from a JavaScript value.
  class FromAny a where
    -- | Convert a value from JS with a reasonable conversion if an exact match
    --   is not possible. Examples of reasonable conversions would be truncating
    --   floating point numbers to integers, or turning signed integers into
    --   unsigned.
    --
    --   The default instance is the inverse of the default 'ToAny' instance.
    fromAny :: JSAny -> IO a
    default fromAny :: (GToAny (Rep a), GFromAny (Rep a), Generic a)
                    => JSAny -> IO a
    fromAny x = to <$> gFromAny False x
  
    listFromAny :: JSAny -> IO [a]
    listFromAny = mapM fromAny . fromPtr . __arr2lst 0
  
  -- | The Opaque type is inhabited by values that can be passed to JavaScript
  --   using their raw Haskell representation. Opaque values are completely
  --   useless to JS code, and should not be inspected. This is useful for,
  --   for instance, storing data in some JS-native data structure for later
  --   retrieval.
  newtype Opaque a = Opaque {fromOpaque :: a}
  
  toOpaque :: a -> Opaque a
  toOpaque = Opaque
  
  
  
  -- ToAny instances
  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 = unsafeCoerce
  
  -- | Lists are marshalled into arrays, with the exception of 'String'.
  instance ToAny a => ToAny [a] where
    toAny = listToAny
  
  -- | Maybe is simply a nullable type. Nothing is equivalent to null, and any
  --   non-null value is equivalent to x in Just x.
  instance ToAny a => ToAny (Maybe a) where
    toAny Nothing  = jsNull
    toAny (Just x) = toAny x
  
  -- | Tuples are marshalled into arrays.
  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))
  
  -- unsafeCoerce for Float and Double saves a lot on performance, and only
  -- differs in semantics if the value in question is a) not a number, and
  -- b) passed verbatim back into JS land
  instance FromAny Float where
    fromAny x = return (unsafeCoerce x)
  instance FromAny Double where
    fromAny x = return (unsafeCoerce 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 = return . unsafeCoerce
  
  instance FromAny a => FromAny [a] where
    fromAny = listFromAny
  
  instance FromAny a => FromAny (Maybe a) where
    fromAny x | x == jsNull || isUndefined x = 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)]
  
  -- GToAny instances
  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 {-# OVERLAPPABLE #-} (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 ())
  
  
  
  
  
  -- GFromAny instances
  class GFromAny f where
    gFromAny   :: Bool -> JSAny -> IO (f a)
    isRecord   :: f a -> Bool
    gFromList  :: Int -> JSAny -> IO (f a, Int)
    gFromList = error "gFromList called on non-product!"
  
  instance GFromAny U1 where
    gFromAny _ _ = return U1
    isRecord _ = False
  
  instance (ToAny a, FromAny a) => GFromAny (K1 i a) where
    gFromAny _ x = do
      x' <- fromAny x
      return $ K1 x'
    isRecord _ = False
    gFromList ix x = do
      x' <- x `index` ix
      return (K1 x', ix+1)
  
  instance (Selector c, GFromAny a) => GFromAny (M1 S c a) where
    gFromAny mcs x = do
        exists <- x `has` prop
        if exists
          then M1 <$> (get x prop >>= gFromAny mcs)
          else error $ "No such member: '" ++ sn ++ "'"
      where
        sn   = selName (undefined :: M1 S c a ())
        prop = toJSStr sn
    isRecord _ = not (null $ selName (undefined :: M1 S c a ()))
    gFromList ix x = do
      (x', ix') <- gFromList ix x
      return (M1 x', ix')
  
  instance Constructor c => GFromAny (M1 C c U1) where
    gFromAny _ x = do
        n <- fromAny x
        if (n == cn)
          then return $ M1 U1
          else error $  "Couldn't fromAny constructor: expected " ++ cn
                     ++ " but got " ++ n
      where
        cn = conName (undefined :: M1 C c U1 ())
    isRecord _ = False
  
  instance {-# OVERLAPPABLE #-} (Constructor c, GFromAny a) =>
                                 GFromAny (M1 C c a) where
    gFromAny many_constrs x
      | many_constrs = do
          t <- x `get` "$tag"
          if t == tag
            then M1 <$> (x `get` "$data" >>= gFromAny many_constrs)
            else error $  "Couldn't fromAny constructor: expected " ++ tag
                       ++ " but got " ++ t
      | isRecord (undefined :: a ()) = do
          M1 <$> gFromAny many_constrs x
      | otherwise = do
          M1 . fst <$> gFromList 0 x
      where
        tag = conName (undefined :: M1 C c a ())
    isRecord _ = isRecord (undefined :: a ())
  
  instance GFromAny a => GFromAny (M1 D c a) where
    gFromAny cs x = M1 <$> gFromAny cs x
    isRecord _ = isRecord (undefined :: a ())
    gFromList ix x = do
      (x', ix') <- gFromList ix x
      return (M1 x', ix')
  
  instance (GFromAny a, GFromAny b) => GFromAny (a :*: b) where
    gFromAny cs x = do
      a <- gFromAny cs x
      b <- gFromAny cs x
      return (a :*: b)
    isRecord _ = isRecord (undefined :: a ())
    gFromList ix x = do
      (a, ix') <- gFromList ix x
      (b, ix'') <- gFromList ix' x
      return (a :*: b, ix'')
  
  instance (GFromAny a, GFromAny b) => GFromAny (a :+: b) where
    gFromAny _ x = do
      catch (L1 <$> gFromAny True x)
            (withSomeException $ R1 <$> gFromAny True x)
    isRecord _ = isRecord (undefined :: a ()) || isRecord (undefined :: b ())
  
  withSomeException :: IO a -> SomeException -> IO a
  withSomeException m _ = m
  