diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Anton Ekblad + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Anton Ekblad nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haste-prim.cabal b/haste-prim.cabal new file mode 100644 --- /dev/null +++ b/haste-prim.cabal @@ -0,0 +1,58 @@ +-- Initial haste-prim.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: haste-prim +version: 0.6.0.0 +synopsis: Low level primitives for the Haste compiler. +description: FFI and low-level hackery for haste-lib to build on. +homepage: http://haste-lang.org +license: BSD3 +license-file: LICENSE +author: Anton Ekblad +maintainer: anton@ekblad.cc +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +flag haste + description: Is haste-prim being installed for Haste? + default: False + +library + exposed-modules: + Haste.Prim + Haste.Prim.Any + Haste.Prim.Foreign + Haste.Prim.JSType + other-extensions: + ForeignFunctionInterface + OverloadedStrings + BangPatterns + CPP + TypeFamilies + FlexibleInstances + UndecidableInstances + OverlappingInstances + PatternGuards + TypeOperators + ScopedTypeVariables + FlexibleContexts + DefaultSignatures + TupleSections + EmptyDataDecls + MagicHash + TypeSynonymInstances + UnboxedTuples + MultiParamTypeClasses + UnliftedFFITypes + build-depends: + base >=4.6 && <4.9, + ghc-prim >=0.3 && <0.5 + if !flag(haste) + build-depends: integer-gmp >=0.5 && <2 + else + build-depends: integer-gmp >=0.5 && <0.6 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Haste/Prim.hs b/src/Haste/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Prim.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, MagicHash, + TypeSynonymInstances, FlexibleInstances, CPP, UnboxedTuples #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haste.Prim ( + JSString (..), URL, toJSStr, fromJSStr, catJSStr, JSAny (..), + Ptr, toPtr, fromPtr, veryUnsafePerformIO) where +import Foreign.Ptr +import Data.String +#ifdef __HASTE__ +import Unsafe.Coerce +import GHC.CString +import qualified GHC.HastePrim as HP +#else +import Data.List (intercalate) +#endif +import GHC.Prim +import GHC.Types (IO (..)) + +type URL = JSString + +-- | Any JS value, with one layer of indirection. +newtype JSAny = JSAny (Ptr Any) + +instance Eq JSAny where + (==) = __eq + +{-# INLINE veryUnsafePerformIO #-} +-- | Strict, inlineable, dupable version of 'unsafePerformIO'. Only use if you +-- are extremely sure this is not a problem. So please don't. +veryUnsafePerformIO :: IO a -> a +veryUnsafePerformIO (IO act) = + case act realWorld# of + (# _, x #) -> x + +-- | Concatenate a series of JSStrings using the specified separator. +catJSStr :: JSString -> [JSString] -> JSString +#ifdef __HASTE__ +foreign import ccall jsCat :: Ptr [JSString] -> JSString -> JSString +foreign import ccall __eq :: JSAny -> JSAny -> Bool +catJSStr sep strs = jsCat (toPtr strs) sep +#else +catJSStr sep strs = toJSStr $ intercalate (fromJSStr sep) (map fromJSStr strs) +__eq :: JSAny -> JSAny -> Bool +__eq _ _ = undefined +#endif + +#ifdef __HASTE__ +foreign import ccall strEq :: JSString -> JSString -> Bool +foreign import ccall strOrd :: JSString -> JSString -> Ptr Ordering + +-- | Native JavaScript strings. +newtype JSString = JSString JSAny + +instance Eq JSString where + (==) = strEq + +instance Ord JSString where + compare a b = fromPtr (strOrd a b) + +instance Show JSString where + show = fromJSStr + +-- | In normal Haskell, we use Storable for data that can be pointed to. When +-- we compile to JS, however, anything can be "pointed" to and nothing needs +-- to be stored. +toPtr :: a -> Ptr a +toPtr = unsafeCoerce + +-- | Unwrap a "pointer" to something. +fromPtr :: Ptr a -> a +fromPtr = unsafeCoerce + +{-# RULES "toJSS/fromJSS" forall s. toJSStr (fromJSStr s) = s #-} +{-# RULES "fromJSS/toJSS" forall s. fromJSStr (toJSStr s) = s #-} +{-# RULES "toJSS/unCSTR" forall s. toJSStr (unpackCString# s) = + JSString (JSAny (toPtr (unsafeCoerce# s))) #-} +{-# RULES "toJSS/unCSTRU8" forall s. toJSStr (unpackCStringUtf8# s) = + JSString (JSAny (toPtr (unsafeCoerce# s))) #-} + +-- | Convert a 'String' to a 'JSString'. +{-# NOINLINE [1] toJSStr #-} +toJSStr :: String -> JSString +toJSStr = unsafeCoerce# HP.toJSStr + +instance IsString JSString where + fromString = toJSStr + +-- | Convert a 'JSString' to a 'String'. +{-# NOINLINE [1] fromJSStr #-} +fromJSStr :: JSString -> String +fromJSStr = unsafeCoerce# HP.fromJSStr + +#else + +-- | JSStrings are represented as normal strings server-side; should probably +-- be changed to ByteString or Text. +newtype JSString = JSString String + +instance IsString JSString where + fromString = JSString + +instance Eq JSString where + (JSString a) == (JSString b) = a == b + +instance Ord JSString where + (JSString a) `compare` (JSString b) = a `compare` b + +instance Show JSString where + show = fromJSStr + +toJSStr :: String -> JSString +toJSStr = JSString + +fromJSStr :: JSString -> String +fromJSStr (JSString s) = s + +toPtr :: a -> Ptr a +toPtr = error "toPtr used in native code!" + +fromPtr :: Ptr a -> a +fromPtr = error "fromPtr used in native code!" + +#endif diff --git a/src/Haste/Prim/Any.hs b/src/Haste/Prim/Any.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Prim/Any.hs @@ -0,0 +1,462 @@ +-- 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 diff --git a/src/Haste/Prim/Foreign.hs b/src/Haste/Prim/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Prim/Foreign.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, BangPatterns, CPP #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | High level JavaScript foreign interface. +module Haste.Prim.Foreign + ( module Haste.Prim.Any + , FFI, JSFunc, JSException (..) + , ffi, constant, export + , safe_ffi, StaticPtr + ) where +import Haste.Prim +import Haste.Prim.Any +import GHC.StaticPtr (StaticPtr, deRefStaticPtr) +import Unsafe.Coerce +import Control.Exception +import Data.Typeable + +-- | A JS function. +type JSFun = JSAny + +#ifdef __HASTE__ +foreign import ccall __strict :: JSAny -> JSAny +foreign import ccall "eval" __eval :: JSString -> JSFun +foreign import ccall __apply :: JSFun -> Ptr [JSAny] -> IO JSAny +foreign import ccall __app0 :: JSFun -> IO JSAny +foreign import ccall __app1 :: JSFun -> JSAny -> IO JSAny +foreign import ccall __app2 :: JSFun -> JSAny -> JSAny -> IO JSAny +foreign import ccall __app3 :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny +foreign import ccall __app4 :: JSFun + -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny +foreign import ccall __app5 :: JSFun + -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny + -> IO JSAny +foreign import ccall __createJSFunc :: Int -> JSAny -> IO JSAny +#else +__strict :: JSAny -> JSAny +__strict x = x +__eval :: JSString -> JSFun +__eval _ = undefined +__apply :: JSFun -> Ptr [JSAny] -> IO JSAny +__apply _ _ = return undefined +__app0 :: JSFun -> IO JSAny +__app0 _ = return undefined +__app1 :: JSFun -> JSAny -> IO JSAny +__app1 _ _ = return undefined +__app2 :: JSFun -> JSAny -> JSAny -> IO JSAny +__app2 _ _ _ = return undefined +__app3 :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny +__app3 _ _ _ _ = return undefined +__app4 :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny +__app4 _ _ _ _ _ = return undefined +__app5 :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny +__app5 _ _ _ _ _ _ = return undefined +__createJSFunc :: Int -> JSAny -> IO JSAny +__createJSFunc _ = return undefined +#endif + +-- | Any type that can be imported from JavaScript. This means any type which +-- has an instance of 'FromAny', and any function where all argument types +-- has 'ToAny' instances and the return type is in the IO monad and has a +-- 'FromAny' instance. +class FFI a where + __ffi :: JSFun -> [JSAny] -> a + +instance FromAny a => FFI (IO a) where + {-# INLINE __ffi #-} + __ffi = ffiio + +instance (ToAny a, FFI b) => FFI (a -> b) where + {-# INLINE __ffi #-} + __ffi f !as !a = __ffi f (a' : as) + where !a' = toAny a + +{-# INLINE [0] ffiio #-} +-- | Apply the result of an FFI call. +ffiio :: FromAny a => JSFun -> [JSAny] -> IO a +ffiio !f !as = __apply f (toPtr as) >>= fromAny + +{-# INLINE ffi #-} +-- | Creates a Haskell function from the given string of JavaScript code. If +-- this code is not well typed or is otherwise incorrect, your program may +-- crash or misbehave in mystifying ways. Haste makes a best-effort try to +-- save you from poorly typed JS here, but there are no guarantees. +-- +-- For instance, the following WILL cause crazy behavior due to wrong types: +-- +-- > ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int +-- +-- In other words, this function is as unsafe as the JS it calls on. You +-- have been warned. +-- +-- The imported JS is evaluated lazily, unless (a) it is a function object +-- in which case evaluation order does not affect the semantics of the +-- imported code, or if (b) the imported code is explicitly marked as strict: +-- +-- > someFunction = ffi "__strict(someJSFunction)" +-- +-- Literals which depends on some third party initialization, the existence +-- of a DOM tree or some other condition which is not fulfilled at load time +-- should *not* be marked strict. +ffi :: FFI a => JSString -> a +ffi s = __ffi f [] + where + {-# NOINLINE f #-} + f = __eval s + +safe_ffi :: FFI a => StaticPtr JSString -> a +safe_ffi = ffi . deRefStaticPtr + +-- | Create a Haskell value from a constant JS expression. +constant :: FromAny a => JSString -> a +constant = veryUnsafePerformIO . fromAny . __eval + +-- Don't build intermediate list for functions of <= 5 arguments. +{-# RULES +"app0" [1] forall f. ffiio f [] = __app0 f >>= fromAny +"app1" [1] forall f a. ffiio f [a] = __app1 f a >>= fromAny +"app2" [1] forall f a b. ffiio f [b,a] = __app2 f a b >>= fromAny +"app3" [1] forall f a b c. ffiio f [c,b,a] = __app3 f a b c >>= fromAny +"app4" [1] forall f a b c d. ffiio f [d,c,b,a] = __app4 f a b c d >>= fromAny +"app5" [1] forall f a b c d e. ffiio f [e,d,c,b,a] = + __app5 f a b c d e >>= fromAny + #-} + +-- | Export a symbol. That symbol may then be accessed from JavaScript through +-- @Haste.name()@ as a normal function. Remember, however, that if you are +-- using --with-js to include your JS, in conjunction with +-- --opt-minify or any option that implies it, you will instead need +-- to access your exports through @Haste[\'name\']()@, or Closure will mangle +-- your function names. +{-# INLINE export #-} +export :: ToAny a => JSString -> a -> IO () +export = ffi "(function(s,f){Haste[s] = f;})" + +type family JS a where + JS (a -> b) = JSAny -> JS b + JS (IO a) = IO JSAny + JS a = JSAny + +class JSFunc a where + mkJSFunc :: a -> JS a + arity :: a -> Int + +instance {-# OVERLAPPABLE #-} (ToAny a, JS a ~ JSAny) => JSFunc a where + mkJSFunc = toAny + arity _ = 0 + +{-# INLINE strictly #-} +strictly :: a -> a +strictly x = unsafeCoerce (__strict (unsafeCoerce x)) + +{-# RULES + "strictly" forall x. __strict x + = unsafeCoerce x + #-} + +instance ToAny a => JSFunc (IO a) where + mkJSFunc = fmap toAny + arity _ = 1 + +instance (FromAny a, JSFunc b) => JSFunc (a -> b) where + mkJSFunc f = mkJSFunc . f . strictly . veryUnsafePerformIO . fromAny + arity f = 1 + arity (f undefined) + +instance (FromAny a, JSFunc b) => ToAny (a -> b) where + toAny f = + strictly . veryUnsafePerformIO . __createJSFunc (arity f) . toAny . toOpaque $ mkJSFunc f + +instance ToAny a => ToAny (IO a) where + toAny = strictly . veryUnsafePerformIO . __createJSFunc 0 . toAny . toOpaque . mkJSFunc + +instance {-# OVERLAPPABLE #-} FFI a => FromAny a where + fromAny f = return $ __ffi f [] + +-- | An exception raised from foreign JavaScript code. +data JSException = JSException JSString + deriving (Show, Typeable) + +instance Exception JSException where + displayException (JSException e) = "JavaScript exception: " ++ fromJSStr e diff --git a/src/Haste/Prim/JSType.hs b/src/Haste/Prim/JSType.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Prim/JSType.hs @@ -0,0 +1,287 @@ +{-# 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