JSType.hs

{-# LANGUAGE MultiParamTypeClasses, ForeignFunctionInterface, MagicHash, 
             TypeSynonymInstances, FlexibleInstances, EmptyDataDecls,
             UnliftedFFITypes, UndecidableInstances, CPP, OverloadedStrings #-}
-- | Efficient conversions to and from JS native types.
module Haste.Prim.JSType (
    JSType (..), JSNum (..), toString, fromString, convert
  ) where
import GHC.Int
import GHC.Word
import Haste.Prim (JSString (..), toJSStr, fromJSStr)
#ifdef __HASTE__
import Haste.Prim (JSAny (..))
import GHC.Prim
import GHC.Integer.GMP.Internals
import GHC.Types (Int (..))
#else
import Data.Char
import GHC.Float
#endif

-- | Any type which can be converted to/from a 'JSString'.
class JSType a where
  toJSString   :: a -> JSString
  fromJSString :: JSString -> Maybe a

-- | (Almost) all numeric types can be efficiently converted to and from
--   Double, which is the internal representation for most of them.
class JSNum a where
  toNumber   :: a -> Double
  fromNumber :: Double -> a

instance JSType JSString where
  toJSString   = id
  fromJSString = Just

#ifdef __HASTE__

foreign import ccall "Number" jsNumber          :: JSString -> Double
foreign import ccall "String" jsString          :: Double -> JSString
foreign import ccall jsTrunc                    :: Double -> Int
foreign import ccall "I_toInt" jsIToInt         :: ByteArray# -> Int
foreign import ccall "I_toString" jsIToString   :: ByteArray# -> JSString
foreign import ccall "I_fromString" jsStringToI :: JSString -> ByteArray#
foreign import ccall "I_fromNumber" jsNumToI    :: ByteArray# -> ByteArray#

unsafeToJSString :: a -> JSString
unsafeToJSString = unsafeCoerce# jsString

unsafeIntFromJSString :: JSString -> Maybe Int
unsafeIntFromJSString s =
    case jsNumber s of
      d | isNaN d   -> Nothing
        | otherwise -> Just (unsafeCoerce# (jsTrunc d))


-- JSNum instances

instance JSNum Char where
  fromNumber = unsafeCoerce# jsTrunc
  toNumber = unsafeCoerce#

instance JSNum Int where
  fromNumber = unsafeCoerce# jsTrunc
  toNumber = unsafeCoerce#

instance JSNum Int8 where
  fromNumber n = case fromNumber n of I# n' -> I8# (narrow8Int# n')
  toNumber = unsafeCoerce#

instance JSNum Int16 where
  fromNumber n = case fromNumber n of I# n' -> I16# (narrow16Int# n')
  toNumber = unsafeCoerce#

instance JSNum Int32 where
  fromNumber = unsafeCoerce# jsTrunc
  toNumber = unsafeCoerce#

instance JSNum Word where
  fromNumber n =
    case jsTrunc (unsafeCoerce# n) of
      I# n' -> W# (int2Word# n')
  toNumber = unsafeCoerce#

instance JSNum Word8 where
  fromNumber w = case fromNumber w of W# w' -> W8# (narrow8Word# w')
  toNumber = unsafeCoerce#

instance JSNum Word16 where
  fromNumber w = case fromNumber w of W# w' -> W16# (narrow16Word# w')
  toNumber = unsafeCoerce#

instance JSNum Word32 where
  fromNumber w = case fromNumber w of W# w' -> W32# w'
  toNumber = unsafeCoerce#

instance JSNum Integer where
  toNumber (S# n) = toNumber (I# n)
  toNumber (J# n) = unsafeCoerce# (jsIToInt n)
  fromNumber n    = J# (jsNumToI (unsafeCoerce# n))

instance JSNum Float where
  fromNumber = unsafeCoerce#
  toNumber = unsafeCoerce#

instance JSNum Double where
  fromNumber = id
  toNumber = id

-- JSType instances
instance JSType Bool where
  toJSString True = "true"
  toJSString _    = "false"
  fromJSString "true"  = Just True
  fromJSString "false" = Just False
  fromJSString _       = Nothing
instance JSType Int where
  toJSString = unsafeToJSString
  fromJSString = unsafeIntFromJSString
instance JSType Int8 where
  toJSString = unsafeToJSString
  fromJSString = fmap fromIntegral . unsafeIntFromJSString
instance JSType Int16 where
  toJSString = unsafeToJSString
  fromJSString = fmap fromIntegral . unsafeIntFromJSString
instance JSType Int32 where
  toJSString = unsafeToJSString
  fromJSString = unsafeCoerce# unsafeIntFromJSString
instance JSType Word where
  toJSString = unsafeToJSString
  fromJSString = fmap fromIntegral . unsafeIntFromJSString
instance JSType Word8 where
  toJSString = unsafeToJSString
  fromJSString = fmap fromIntegral . unsafeIntFromJSString
instance JSType Word16 where
  toJSString = unsafeToJSString
  fromJSString = fmap fromIntegral . unsafeIntFromJSString
instance JSType Word32 where
  toJSString = unsafeToJSString
  fromJSString = fmap fromIntegral . unsafeIntFromJSString

instance JSType Float where
  fromJSString s =
    case jsNumber s of
      d | isNaN d   -> Nothing
        | otherwise -> Just (unsafeCoerce# d)
  toJSString = unsafeToJSString

instance JSType Double where
  fromJSString s =
    case jsNumber s of
      d | isNaN d   -> Nothing
        | otherwise -> Just d
  toJSString = unsafeToJSString

-- This is completely insane, but GHC for some reason pukes when we try to
-- use the constructors of the actual integers, so we coerce them into this
-- isomorphic type to work with them instead.
data Dummy = Small Int# | Big ByteArray#

instance JSType Integer where
  toJSString n =
    case unsafeCoerce# n of
      Small n' -> toJSString (I# n')
      Big n'   -> jsIToString n'
  fromJSString s =
    case jsStringToI s of
      n -> Just (unsafeCoerce# (Big n))

instance JSType String where
  toJSString     = toJSStr
  fromJSString   = Just . fromJSStr

instance JSType () where
  toJSString _ = toJSStr "()"
  fromJSString s | s == toJSStr "()" = Just ()
                 | otherwise = Nothing

#else

instance JSNum Char where
  toNumber = fromIntegral . ord
  fromNumber = chr . round

instance JSNum Int where
  toNumber = fromIntegral
  fromNumber = round
instance JSNum Int8 where
  toNumber = fromIntegral
  fromNumber = round
instance JSNum Int16 where
  toNumber = fromIntegral
  fromNumber = round
instance JSNum Int32 where
  toNumber = fromIntegral
  fromNumber = round

instance JSNum Word where
  toNumber = fromIntegral
  fromNumber = round
instance JSNum Word8 where
  toNumber = fromIntegral
  fromNumber = round
instance JSNum Word16 where
  toNumber = fromIntegral
  fromNumber = round
instance JSNum Word32 where
  toNumber = fromIntegral
  fromNumber = round

instance JSNum Double where
  toNumber = id
  fromNumber = id
instance JSNum Float where
  toNumber = float2Double
  fromNumber = double2Float

instance JSNum Integer where
  toNumber = fromInteger
  fromNumber = round

mread :: Read a => String -> Maybe a
mread s =
  case reads s of
    [(x, "")] -> x
    _         -> Nothing

instance JSType Int where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr
instance JSType Int8 where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr
instance JSType Int16 where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr
instance JSType Int32 where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr

instance JSType Word where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr
instance JSType Word8 where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr
instance JSType Word16 where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr
instance JSType Word32 where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr

instance JSType Double where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr
instance JSType Float where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr

instance JSType Integer where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr

instance JSType Bool where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr

instance JSType () where
  toJSString = toJSStr . show
  fromJSString = mread . fromJSStr

instance JSType String where
  toJSString = toJSStr
  fromJSString = Just . fromJSStr

#endif

-- Derived functions

toString :: JSType a => a -> String
toString = fromJSStr . toJSString

fromString :: JSType a => String -> Maybe a
fromString = fromJSString . toJSStr

convert :: (JSNum a, JSNum b) => a -> b
convert = fromNumber . toNumber