content: {-# LANGUAGE MagicHash, CPP, MultiParamTypeClasses, OverloadedStrings,
               TypeSynonymInstances , FlexibleInstances,
               GeneralizedNewtypeDeriving, BangPatterns, TypeOperators,
               KindSignatures, DefaultSignatures, FlexibleInstances,
               TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables,
               TupleSections #-}
  -- | Handling of Javascript-native binary blobs.
  --
  -- Generics borrowed from the binary package by Lennart Kolmodin (released under BSD3)
  module Haste.Binary
    ( -- * High level binary API
      MonadConc, Binary (..), Blob, BlobData, encode, decode, decodeBlob
    , module Haste.Binary.Put
    , module Haste.Binary.Get
    , Word8, Word16, Word32, Word64
    , Int8, Int16, Int32, Int64
  
      -- * Working with raw blobs
    , Ix, ArrView
    , getBlobData, getBlobText', getBlobText
    , blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob
    , toUArray, fromUArray
    ) where
  import Data.Array.Unboxed
  import Data.Bits
  import Data.Char
  import Data.Int
  import Data.Word
  import GHC.Fingerprint.Type
  import GHC.Generics
  import qualified Haste.JSString as J (length)
  import Haste.Prim
  import Haste.Concurrent
  import Haste.Prim.Foreign hiding (get)
  import Haste.Binary.Types
  import Haste.Binary.Put
  import Haste.Binary.Get
  #ifndef __HASTE__
  import qualified Data.ByteString.Lazy.Char8 as BS (unpack)
  #endif
  
  -- | Retrieve the raw data from a blob.
  getBlobData  :: MonadConc m => Blob -> m BlobData
  -- | Interpret a blob as UTF-8 text, as a JSString.
  getBlobText' :: MonadConc m => Blob -> m JSString
  
  #ifdef __HASTE__
  getBlobData b = liftCIO $ do
      res <- newEmptyMVar
      liftIO $ convertBlob b (mkBlobData res (blobSize b))
      takeMVar res
    where
      mkBlobData res len x = concurrent $ do
        putMVar res (BlobData 0 len x)
  
      convertBlob :: Blob -> (JSAny -> IO ()) -> IO ()
      convertBlob = ffi "(function(b,cb){var r=new FileReader();r.onload=function(){cb(new DataView(r.result));};r.readAsArrayBuffer(b);})"
  
  getBlobText' b = liftCIO $ do
      res <- newEmptyMVar
      liftIO $ convertBlob b (concurrent . putMVar res)
      takeMVar res
    where
      convertBlob :: Blob -> (JSString -> IO ()) -> IO ()
      convertBlob = ffi "(function(b,cb){var r=new FileReader();r.onload=function(){cb(r.result);};r.readAsText(b);})"
  #else
  getBlobData (Blob b) = return (BlobData b)
  getBlobText' (Blob b) = return . toJSStr $ BS.unpack b
  #endif
  
  
  -- | Interpret a blob as UTF-8 text.
  getBlobText :: MonadConc m => Blob -> m String
  getBlobText b = getBlobText' b >>= return . fromJSStr
  
  -- | Somewhat efficient serialization/deserialization to/from binary Blobs.
  --   The layout of the binaries produced/read by get/put and encode/decode may
  --   change between versions. If you need a stable binary format, you should
  --   make your own using the primitives in Haste.Binary.Get/Put.
  class Binary a where
    get :: Get a
    put :: a -> Put
  
    default put :: (Generic a, GBinary (Rep a)) => a -> Put
    put = gput . from
  
    default get :: (Generic a, GBinary (Rep a)) => Get a
    get = to `fmap` gget
  
  -- | Generic version
  class GBinary f where
      gput :: f t -> Put
      gget :: Get (f t)
  
  instance Binary Bool where
    put True = putWord8 1
    put _    = putWord8 0
    get = do
      n <- getWord8
      case n of
        0 -> pure False
        1 -> pure True
        _ -> fail $ "Not a valid Bool: " ++ show n
  
  instance Binary Word8 where
    put = putWord8
    get = getWord8
  
  instance Binary Word16 where
    put = putWord16le
    get = getWord16le
  
  instance Binary Word32 where
    put = putWord32le
    get = getWord32le
  
  instance Binary Word64 where
    get = do
      lo <- get :: Get Word32
      hi <- get :: Get Word32
      return $ fromIntegral lo .|. shiftL (fromIntegral hi) 32
    put x = do
      put (fromIntegral x :: Word32)
      put (fromIntegral (shiftR x 32) :: Word32)
  
  instance Binary Int8 where
    put = putInt8
    get = getInt8
  
  instance Binary Int16 where
    put = putInt16le
    get = getInt16le
  
  instance Binary Int32 where
    put = putInt32le
    get = getInt32le
  
  instance Binary Int64 where
    get = do
      lo <- get :: Get Int32
      hi <- get :: Get Int32
      return $ fromIntegral lo .|. shiftL (fromIntegral hi) 32
    put x = do
      put (fromIntegral x :: Int32)
      put (fromIntegral (shiftR x 32) :: Int32)
  
  instance Binary Int where
    put = putInt32le . fromIntegral
    get = fromIntegral <$> getInt32le
  
  instance Binary Float where
    put = putFloat32le
    get = getFloat32le
  
  instance Binary Double where
    put = putFloat64le
    get = getFloat64le
  
  instance Binary Fingerprint where
    get = Fingerprint <$> get <*> get
    put (Fingerprint a b) = put a >> put b
  
  instance (Binary a, Binary b) => Binary (a, b) where
    put (a, b) = put a >> put b
    get = (,) <$> get <*> get
  instance (Binary a, Binary b, Binary c) => Binary (a, b, c) where
    put (a, b, c) = put a >> put b >> put c
    get = (,,) <$> get <*> get <*> get
  instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) where
    put (a, b, c, d) = put a >> put b >> put c >> put d
    get = (,,,) <$> get <*> get <*> get <*> get
  instance (Binary a, Binary b, Binary c, Binary d, Binary e)
           => Binary (a, b, c, d, e) where
    put (a, b, c, d, e) = put a >> put b >> put c >> put d >> put e
    get = (,,,,) <$> get <*> get <*> get <*> get <*> get
  instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
           => Binary (a, b, c, d, e, f) where
    put (a, b, c, d, e, f) = put a >> put b >> put c >> put d >> put e >> put f
    get = (,,,,,) <$> get <*> get <*> get <*> get <*> get <*> get
  instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
           => Binary (a, b, c, d, e, f, g) where
    put (a, b, c, d, e, f, g) = put a>>put b>>put c>>put d>>put e>>put f>>put g
    get = (,,,,,,) <$> get <*> get <*> get <*> get <*> get <*> get <*> get
  
  instance Binary a => Binary (Maybe a) where
    put (Just x) = putWord8 1 >> put x
    put _        = putWord8 0
    get = do
      tag <- getWord8
      case tag of
        0 -> return Nothing
        1 -> Just <$> get
        _ -> fail "Wrong constructor tag when reading Maybe value!"
  
  instance (Binary a, Binary b) => Binary (Either a b) where
    put (Left x)  = putWord8 0 >> put x
    put (Right x) = putWord8 1 >> put x
    get = do
      tag <- getWord8
      case tag of
        0 -> Left <$> get
        1 -> Right <$> get
        _ -> fail "Wrong constructor tag when reading Either value!"
  
  instance Binary () where
    put _ = return ()
    get = return ()
  
  instance Binary a => Binary [a] where
    put xs = do
      putWord32le (fromIntegral $ length xs)
      mapM_ put xs
    get = getWord32le >>= getMany
  
  instance Binary JSString where
    {-# NOINLINE put #-}
    put s = do
      putWord32le $ fromIntegral $ J.length s
      putJSString s
    {-# NOINLINE get #-}
    get = get >>= getJSString
      
  instance Binary Blob where
    {-# NOINLINE put #-}
    put b = do
      put (blobSize b)
      putBlob b
    {-# NOINLINE get #-}
    get = do
      sz <- get
      bd <- getBytes sz
      return $ toBlob bd
  
  instance Binary Char where
    put = put . ord
    get = get >>= \x ->
      case chr x of
        !x' -> return x'
  
  -- Borrowed from the @binary@ package.
  instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
    put a = do
      put (bounds a)
      put (rangeSize $ bounds a)
      mapM_ put (elems a)
    get = do
      bs <- get
      n  <- get
      xs <- getMany n
      return (listArray bs xs)
  
  -- | 'getMany n' get 'n' elements in order, without blowing the stack.
  {-# INLINE getMany #-}
  getMany :: Binary a => Word32 -> Get [a]
  getMany n = go [] n
   where
      go xs 0 = return $! reverse xs
      go xs i = do x <- get
                   -- we must seq x to avoid stack overflows due to laziness in
                   -- (>>=)
                   x `seq` go (x:xs) (i-1)
  
  -- | Encode any serializable data into a 'Blob'.
  encode :: Binary a => a -> Blob
  encode x = runPut (put x)
  
  -- | Decode any deserializable data from a 'BlobData'.
  decode :: Binary a => BlobData -> Either JSString a
  decode = runGet get
  
  -- | Decode a 'Blob' into some deserializable value, inconveniently locked up
  --   inside the 'CIO' monad (or any other concurrent monad) due to the somewhat
  --   special way JavaScript uses to deal with binary data.
  decodeBlob :: (MonadConc m, Binary a) => Blob -> m (Either JSString a)
  decodeBlob b = getBlobData b >>= return . decode
  
  -- Type without constructors
  instance GBinary V1 where
      gput _ = return ()
      gget   = return undefined
  
  -- Constructor without arguments
  instance GBinary U1 where
      gput U1 = return ()
      gget    = return U1
  
  -- Product: constructor with parameters
  instance (GBinary a, GBinary b) => GBinary (a :*: b) where
      gput (x :*: y) = gput x >> gput y
      gget = (:*:) <$> gget <*> gget
  
  -- Metadata (constructor name, etc)
  instance GBinary a => GBinary (M1 i c a) where
      gput = gput . unM1
      gget = M1 <$> gget
  
  -- Constants, additional parameters, and rank-1 recursion
  instance Binary a => GBinary (K1 i a) where
      gput = put . unK1
      gget = K1 <$> get
  
  -- Borrowed from the cereal package.
  
  -- The following GBinary instance for sums has support for serializing
  -- types with up to 2^64-1 constructors. It will use the minimal
  -- number of bytes needed to encode the constructor. For example when
  -- a type has 2^8 constructors or less it will use a single byte to
  -- encode the constructor. If it has 2^16 constructors or less it will
  -- use two bytes, and so on till 2^64-1.
  --
  -- NB: changed to 2^32-1 constructors
  
  #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)
  #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)
  #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
  
  instance ( GSum     a, GSum     b
           , GBinary a, GBinary b
           , SumSize    a, SumSize    b) => GBinary (a :+: b) where
      gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) --  | PUTSUM(Word64)
           | otherwise = sizeError "encode" size
        where
          size = unTagged (sumSize :: Tagged (a :+: b) Word32)
      {-# INLINE gput #-}
  
      gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) --  | GETSUM(Word64)
           | otherwise = sizeError "decode" size
        where
          size = unTagged (sumSize :: Tagged (a :+: b) Word32)
      {-# INLINE gget #-}
  
  sizeError :: Show size => String -> size -> error
  sizeError s size =
      error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"
  
  ------------------------------------------------------------------------
  
  checkGetSum :: (Ord word, Num word, Bits word, GSum f)
              => word -> word -> Get (f a)
  checkGetSum size code | code < size = getSum code size
                        | otherwise   = fail "Unknown encoding for constructor"
  {-# INLINE checkGetSum #-}
  
  class GSum f where
      getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
      putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put
  
  instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where
      getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL
                         | otherwise    = R1 <$> getSum (code - sizeL) sizeR
          where
            sizeL = size `shiftR` 1
            sizeR = size - sizeL
      {-# INLINE getSum #-}
  
      putSum !code !size s = case s of
                               L1 x -> putSum code           sizeL x
                               R1 x -> putSum (code + sizeL) sizeR x
          where
            sizeL = size `shiftR` 1
            sizeR = size - sizeL
      {-# INLINE putSum #-}
  
  instance GBinary a => GSum (C1 c a) where
      getSum _ _ = gget
      {-# INLINE getSum #-}
  
      putSum !code _ x = put code *> gput x
      {-# INLINE putSum #-}
  
  ------------------------------------------------------------------------
  
  class SumSize f where
      sumSize :: Tagged f Word32
  
  newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}
  
  instance (SumSize a, SumSize b) => SumSize (a :+: b) where
      sumSize = Tagged $ unTagged (sumSize :: Tagged a Word32) +
                         unTagged (sumSize :: Tagged b Word32)
  
  instance SumSize (C1 c a) where
      sumSize = Tagged 1
  