From 6b0a0ef278abeeb2b518854b77552db11722847f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bankn8II=C2=A9=24A?= <102619282+barionleg@users.noreply.github.com> Date: Thu, 2 Jan 2025 12:46:31 +0100 Subject: [PATCH] Add files via upload --- javascript-extras/LICENSE | 30 +++ javascript-extras/README.md | 22 ++ javascript-extras/Setup.hs | 2 + javascript-extras/javascript-extras.cabal | 54 ++++ javascript-extras/jsbits/extras.js | 35 +++ javascript-extras/src/JavaScript/Extras.hs | 11 + .../src/JavaScript/Extras/Cast.hs | 243 ++++++++++++++++++ .../src/JavaScript/Extras/JSRep.hs | 58 +++++ .../src/JavaScript/Extras/JSRep/Unsafe.hs | 26 ++ .../src/JavaScript/Extras/Number.hs | 42 +++ .../src/JavaScript/Extras/Property.hs | 96 +++++++ javascript-extras/test/hs/Main.hs | 47 ++++ 12 files changed, 666 insertions(+) create mode 100644 javascript-extras/LICENSE create mode 100644 javascript-extras/README.md create mode 100644 javascript-extras/Setup.hs create mode 100644 javascript-extras/javascript-extras.cabal create mode 100644 javascript-extras/jsbits/extras.js create mode 100644 javascript-extras/src/JavaScript/Extras.hs create mode 100644 javascript-extras/src/JavaScript/Extras/Cast.hs create mode 100644 javascript-extras/src/JavaScript/Extras/JSRep.hs create mode 100644 javascript-extras/src/JavaScript/Extras/JSRep/Unsafe.hs create mode 100644 javascript-extras/src/JavaScript/Extras/Number.hs create mode 100644 javascript-extras/src/JavaScript/Extras/Property.hs create mode 100644 javascript-extras/test/hs/Main.hs diff --git a/javascript-extras/LICENSE b/javascript-extras/LICENSE new file mode 100644 index 0000000..a7844e8 --- /dev/null +++ b/javascript-extras/LICENSE @@ -0,0 +1,30 @@ +Copyright Louis Pan (c) 2017 + +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 Louis Pan 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/javascript-extras/README.md b/javascript-extras/README.md new file mode 100644 index 0000000..4373a31 --- /dev/null +++ b/javascript-extras/README.md @@ -0,0 +1,22 @@ +[![Hackage](https://img.shields.io/hackage/v/javascript-extras.svg)](https://hackage.haskell.org/package/javascript-extras) + +Extra javascript functions when using GHCJS + +# Changelog + +* 0.5.0.0 + - flipped the args of `getProperty` and `setProperty` + This makes it easier for chaining. + +* 0.4.0.0 + - Renamed `JSVar` to `JSRep` to avoid confusion with `JSVal` + - Renamed `toJS'` to `toJSR` + - Renamed `fromJS'` to `fromJSR` + - `getProperty` and `setProperty` uses `JE.ToJS a` instead of `Coercible a J.JSVal` + - flipped the args of `getProperty` and `setProperty` + - Moved `justSnds` to esoteric-extras `Data.Maybe.Esoteric.keepMaybes` + - Renamed `safeModularIncrement` to `safeIncrement` + - Renamed `safeModularDecrement` to `safeDecrement` + +* 0.3.3.0 + - Added `classNames`, `justSnds` diff --git a/javascript-extras/Setup.hs b/javascript-extras/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/javascript-extras/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/javascript-extras/javascript-extras.cabal b/javascript-extras/javascript-extras.cabal new file mode 100644 index 0000000..596b21a --- /dev/null +++ b/javascript-extras/javascript-extras.cabal @@ -0,0 +1,54 @@ +name: javascript-extras +version: 0.5.0.0 +synopsis: Extra javascript functions when using GHCJS +description: Extra javascript functions when using GHCJS +homepage: https://github.com/louispan/javascript-extras#readme +license: BSD3 +license-file: LICENSE +author: Louis Pan +maintainer: louis@pan.me +copyright: 2017 Louis Pan +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + js-sources: jsbits/extras.js + exposed-modules: JavaScript.Extras + JavaScript.Extras.Cast + JavaScript.Extras.Number + JavaScript.Extras.Property + JavaScript.Extras.JSRep + JavaScript.Extras.JSRep.Unsafe + build-depends: base >= 4.7 && < 5 + , deepseq >= 1.4 + , newtype-generics >= 0.5 + , parallel >= 3.2 + , text >= 1.2 + default-language: Haskell2010 + ghc-options: -Wall + if impl(ghcjs) + build-depends: ghcjs-base + if !impl(ghcjs) + build-depends: ghcjs-base-stub >= 0.2 + +executable javascript-extras-test + hs-source-dirs: test/hs + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + cpp-options: -DGHCJS_BROWSER + build-depends: base >= 4.7 && < 5 + , javascript-extras + default-language: Haskell2010 + default-extensions: ApplicativeDo + if impl(ghcjs) + build-depends: ghcjs-base + , ghcjs-prim >= 0.1 + if !impl(ghcjs) + build-depends: ghcjs-base-stub >= 0.2 + +source-repository head + type: git + location: https://github.com/louispan/javascript-extras diff --git a/javascript-extras/jsbits/extras.js b/javascript-extras/jsbits/extras.js new file mode 100644 index 0000000..d09d9b6 --- /dev/null +++ b/javascript-extras/jsbits/extras.js @@ -0,0 +1,35 @@ +// Node module dependencies +// Example package.json: +// { +// "dependencies": { +// "javascript-stringify": "^1.6.0" +// } +// } + +#include + +// zip list of string and JSVal to object, lists must have been completely forced first +// Using the idea from JavaScript.Array.Internal.fromList h$fromHsListJSVal +function hje$fromHsZipListJSVal(names, xs) { + var obj = {}; + while(IS_CONS(names) && IS_CONS(xs)) { + obj[JSVAL_VAL(CONS_HEAD(names))] = JSVAL_VAL(CONS_HEAD(xs)); + names = CONS_TAIL(names); + xs = CONS_TAIL(xs); + } + return obj; +} + +var hge$javascriptStringify_ = null; +function hje$stringify(v) { + if (!hge$javascriptStringify_) { + hge$javascriptStringify_ = require('javascript-stringify'); + } + return hge$javascriptStringify_(v, null, null, { references: true }) +} + +// Injection attack! Use with care +function hje$unstringify(str) { + eval("var ret=" + str); + return ret; +} diff --git a/javascript-extras/src/JavaScript/Extras.hs b/javascript-extras/src/JavaScript/Extras.hs new file mode 100644 index 0000000..0a2df4f --- /dev/null +++ b/javascript-extras/src/JavaScript/Extras.hs @@ -0,0 +1,11 @@ +module JavaScript.Extras + ( module JavaScript.Extras.Cast + , module JavaScript.Extras.JSRep + , module JavaScript.Extras.Number + , module JavaScript.Extras.Property + ) where + +import JavaScript.Extras.Cast +import JavaScript.Extras.JSRep +import JavaScript.Extras.Number +import JavaScript.Extras.Property diff --git a/javascript-extras/src/JavaScript/Extras/Cast.hs b/javascript-extras/src/JavaScript/Extras/Cast.hs new file mode 100644 index 0000000..3f63f54 --- /dev/null +++ b/javascript-extras/src/JavaScript/Extras/Cast.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} + +module JavaScript.Extras.Cast + ( ToJS(..) + , FromJS(..) + ) where + +import qualified Data.JSString as JS +import qualified Data.Text as T +import GHC.Int +import GHC.Word +import qualified GHCJS.Foreign.Callback as J +import qualified GHCJS.Foreign.Export as J +import qualified GHCJS.Foreign.Internal as JFI +import qualified GHCJS.Marshal.Pure as J +import qualified GHCJS.Nullable as J +import qualified GHCJS.Types as J +import qualified JavaScript.Array.Internal as JAI +import qualified JavaScript.Object.Internal as JOI + +-- | This provides a consistent way to convert to JSVal, with different semantics for Char. +-- In the Char's instance of ToJS, it converts to a string instead of integer - IMHO this is less surprising. +-- +-- The other reason for this class is while GHCJS base provide both IsJSVal and PToJSVal to convert to jsval, +-- some types are instances of one or the other class. +-- This means you can't use the "Maybe a" instance of PToJSVal if it contains IsISJVal but not pToJSVal. +class ToJS a where + -- | This is a pure conversion, so instances must be able to convert + -- the same or equivalent JSVal each time. + toJS :: a -> J.JSVal + default toJS :: J.IsJSVal a => a -> J.JSVal + toJS = J.jsval + +instance ToJS J.JSVal where + toJS = id +instance ToJS (J.Callback a) +instance ToJS (J.Export a) +instance ToJS (J.Nullable a) where + toJS (J.Nullable a) = a +instance ToJS (JAI.SomeJSArray m) +instance ToJS JOI.Object +instance ToJS Bool where + toJS = J.pToJSVal +-- | Char instance converts to string +instance ToJS Char where + toJS a = J.pToJSVal [a] +instance ToJS Double where + toJS = J.pToJSVal +instance ToJS Float where + toJS = J.pToJSVal +instance ToJS Int where + toJS = J.pToJSVal +instance ToJS Int8 where + toJS = J.pToJSVal +instance ToJS Int16 where + toJS = J.pToJSVal +instance ToJS Int32 where + toJS = J.pToJSVal +instance ToJS Word where + toJS = J.pToJSVal +instance ToJS Word8 where + toJS = J.pToJSVal +instance ToJS Word16 where + toJS = J.pToJSVal +instance ToJS Word32 where + toJS = J.pToJSVal +instance ToJS T.Text where + toJS = J.pToJSVal +instance ToJS String where + toJS = J.pToJSVal +instance ToJS J.JSString +instance ToJS a => ToJS (Maybe a) where + toJS Nothing = J.nullRef + toJS (Just a) = toJS a + +-- | This provides a consistent way to safely convert from JSVal. +-- The semantics is that if the return value is a Just, then the JSVal is not a null value. +-- Also, Nothing is also returned for values out of range. They are not silently truncated. +-- (Except for Float where there may be loss of precision) during conversion. +-- +-- The reason for this class is because GHCJS.Marshal.fromJSVal and GHCJS.Marshal.pFromJSVal +-- are not safe to use as it assumes that the JSVal are of the correct type and not null. +-- (https://github.com/ghcjs/ghcjs-base/issues/87). +-- The safe way to convert from JSVal is to use JavaScript.Cast or to use the 'Maybe a' instance of FromJSVal, +-- ie @fromJSVal :: JSVal -> IO (Maybe (Maybe a))@, which is a bit more awkward to use, and requires IO. +-- Also, Javascript.Cast doesn't have much instances, and it hardcodes the instance detection method +-- to javascript `isinstance` which is not sufficient for complex types (https://github.com/ghcjs/ghcjs-base/issues/86). +-- +-- It is actually safe to convert from JSVal without IO because every JSVal is a copy of a value or reference. +-- The copy never change, so the conversion will always convert to the same result/object every time. +class FromJS a where + fromJS :: J.JSVal -> Maybe a + +instance FromJS J.JSVal where + fromJS a | J.isUndefined a || J.isNull a = Nothing + fromJS a = Just a + +instance FromJS (JAI.SomeJSArray m) where + fromJS a | JFI.jsonTypeOf a == JFI.JSONArray = Just $ JAI.SomeJSArray a + fromJS _ = Nothing + +instance FromJS JOI.Object where + fromJS a | JFI.jsonTypeOf a == JFI.JSONObject = Just $ JOI.Object a + fromJS _ = Nothing + +instance FromJS Bool where + fromJS a | JFI.jsonTypeOf a == JFI.JSONBool = J.pFromJSVal a + fromJS _ = Nothing + +-- | This will only succeed on a single character string +instance FromJS Char where + fromJS a = + case JFI.jsonTypeOf a of + JFI.JSONString -> + let a' = J.pFromJSVal a -- convert to JSString + mb = JS.uncons a' + in case mb of + Nothing -> Nothing + Just (h, t) -> + if JS.null t + then Just h + else Nothing + _ -> Nothing + +instance FromJS Double where + fromJS a = let t = JFI.jsonTypeOf a + in if t == JFI.JSONInteger || t == JFI.JSONFloat + then J.pFromJSVal a + else Nothing + +instance FromJS Float where + fromJS a = let t = JFI.jsonTypeOf a + in if t == JFI.JSONInteger || t == JFI.JSONFloat + then J.pFromJSVal a + else Nothing + +instance FromJS Int where + fromJS a | JFI.jsonTypeOf a == JFI.JSONInteger && js_withinIntBounds a minBound maxBound = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS Int8 where + fromJS a | JFI.jsonTypeOf a == JFI.JSONInteger && js_withinInt8Bounds a minBound maxBound = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS Int16 where + fromJS a | JFI.jsonTypeOf a == JFI.JSONInteger && js_withinInt16Bounds a minBound maxBound = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS Int32 where + fromJS a | JFI.jsonTypeOf a == JFI.JSONInteger && js_withinInt32Bounds a minBound maxBound = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS Word where + fromJS a | JFI.jsonTypeOf a == JFI.JSONInteger && js_withinWordBounds a minBound maxBound = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS Word8 where + fromJS a | JFI.jsonTypeOf a == JFI.JSONInteger && js_withinWord8Bounds a minBound maxBound = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS Word16 where + fromJS a | JFI.jsonTypeOf a == JFI.JSONInteger && js_withinWord16Bounds a minBound maxBound = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS Word32 where + fromJS a | JFI.jsonTypeOf a == JFI.JSONInteger && js_withinWord32Bounds a minBound maxBound = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS T.Text where + fromJS a | JFI.jsonTypeOf a == JFI.JSONString = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS String where + fromJS a | JFI.jsonTypeOf a == JFI.JSONString = J.pFromJSVal a + fromJS _ = Nothing + +instance FromJS J.JSString where + fromJS a | JFI.jsonTypeOf a == JFI.JSONString = J.pFromJSVal a + fromJS _ = Nothing + +#ifdef __GHCJS__ + +foreign import javascript unsafe + "($1 >= $2) || ($1 <= $3)" + js_withinIntBounds :: J.JSVal -> Int -> Int -> Bool + +foreign import javascript unsafe + "($1 >= $2) || ($1 <= $3)" + js_withinInt8Bounds :: J.JSVal -> Int8 -> Int8 -> Bool + +foreign import javascript unsafe + "($1 >= $2) || ($1 <= $3)" + js_withinInt16Bounds :: J.JSVal -> Int16 -> Int16 -> Bool + +foreign import javascript unsafe + "($1 >= $2) || ($1 <= $3)" + js_withinInt32Bounds :: J.JSVal -> Int32 -> Int32 -> Bool + +foreign import javascript unsafe + "($1 >= $2) || ($1 <= $3)" + js_withinWordBounds :: J.JSVal -> Word -> Word -> Bool + +foreign import javascript unsafe + "($1 >= $2) || ($1 <= $3)" + js_withinWord8Bounds :: J.JSVal -> Word8 -> Word8 -> Bool + +foreign import javascript unsafe + "($1 >= $2) || ($1 <= $3)" + js_withinWord16Bounds :: J.JSVal -> Word16 -> Word16 -> Bool + +foreign import javascript unsafe + "($1 >= $2) || ($1 <= $3)" + js_withinWord32Bounds :: J.JSVal -> Word32 -> Word32 -> Bool + +#else + +js_withinIntBounds :: J.JSVal -> Int -> Int -> Bool +js_withinIntBounds _ _ _ = False + +js_withinInt8Bounds :: J.JSVal -> Int8 -> Int8 -> Bool +js_withinInt8Bounds _ _ _ = False + +js_withinInt16Bounds :: J.JSVal -> Int8 -> Int8 -> Bool +js_withinInt16Bounds _ _ _ = False + +js_withinInt32Bounds :: J.JSVal -> Int8 -> Int8 -> Bool +js_withinInt32Bounds _ _ _ = False + +js_withinWordBounds :: J.JSVal -> Word -> Word -> Bool +js_withinWordBounds _ _ _ = False + +js_withinWord8Bounds :: J.JSVal -> Word8 -> Word8 -> Bool +js_withinWord8Bounds _ _ _ = False + +js_withinWord16Bounds :: J.JSVal -> Word16 -> Word16 -> Bool +js_withinWord16Bounds _ _ _ = False + +js_withinWord32Bounds :: J.JSVal -> Word32 -> Word32 -> Bool +js_withinWord32Bounds _ _ _ = False + +#endif diff --git a/javascript-extras/src/JavaScript/Extras/JSRep.hs b/javascript-extras/src/JavaScript/Extras/JSRep.hs new file mode 100644 index 0000000..2c555f0 --- /dev/null +++ b/javascript-extras/src/JavaScript/Extras/JSRep.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +module JavaScript.Extras.JSRep where + +import Control.DeepSeq +import Control.Newtype.Generics +import Data.Coerce +import Data.JSString as JS +import Data.String +import GHC.Generics +import qualified GHCJS.Marshal.Pure as J +import qualified GHCJS.Types as J +import JavaScript.Extras.Cast as JE + +-- | Wrapper to have a JSVal that also have an IString instance +-- This is helpful when using OverloadedStrings +newtype JSRep = JSRep J.JSVal deriving (Generic) + +instance Newtype JSRep + +instance Show JSRep where + show = JS.unpack . js_stringify + +instance J.IsJSVal JSRep + +instance J.PToJSVal JSRep where + pToJSVal = J.jsval + +instance JE.ToJS JSRep + +instance JE.FromJS JSRep where + fromJS v = coerce (fromJS v :: Maybe J.JSVal) + +instance IsString JSRep where + fromString = JSRep . J.jsval . JS.pack + +instance NFData JSRep where + rnf (JSRep v) = rnf v + +toJSR :: JE.ToJS a => a -> JSRep +toJSR = JSRep . toJS + +fromJSR :: JE.FromJS a => JSRep -> Maybe a +fromJSR (JSRep v) = fromJS v + +#ifdef __GHCJS__ + +foreign import javascript unsafe + "$r = hje$stringify($1);" + js_stringify :: JSRep -> J.JSString + +#else + +js_stringify :: JSRep -> J.JSString +js_stringify _ = JS.empty + +#endif diff --git a/javascript-extras/src/JavaScript/Extras/JSRep/Unsafe.hs b/javascript-extras/src/JavaScript/Extras/JSRep/Unsafe.hs new file mode 100644 index 0000000..cd1d2c5 --- /dev/null +++ b/javascript-extras/src/JavaScript/Extras/JSRep/Unsafe.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} + +module JavaScript.Extras.JSRep.Unsafe where + +import Data.JSString as JS +import qualified GHCJS.Types as J +import JavaScript.Extras.JSRep as JE + +-- | Injection attack! Use with care +instance Read JE.JSRep where + readsPrec _ str = [(js_eval (JS.pack str), [])] + +#ifdef __GHCJS__ + +-- | Injection attack! Use with care +foreign import javascript unsafe + "$r = hje$unstringify($1);" + js_eval :: J.JSString -> JSRep + +#else + +js_eval :: J.JSString -> JSRep +js_eval _ = JSRep J.nullRef + +#endif diff --git a/javascript-extras/src/JavaScript/Extras/Number.hs b/javascript-extras/src/JavaScript/Extras/Number.hs new file mode 100644 index 0000000..93e6619 --- /dev/null +++ b/javascript-extras/src/JavaScript/Extras/Number.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} + +module JavaScript.Extras.Number + ( maxSafeInteger + , minSafeInteger + , safeIncrement + , safeDecrement + ) where + +maxSafeInteger :: Int +maxSafeInteger = js_maxSafeInteger + +minSafeInteger :: Int +minSafeInteger = js_minSafeInteger + +-- | always returns a number between [Number.MIN_SAFE_INTEGER, Number.MAX_SAFE_INTEGER] +safeIncrement :: Int -> Int +safeIncrement i = if i >= maxSafeInteger then minSafeInteger else i + 1 + +-- | always returns a number between [Number.MIN_SAFE_INTEGER, Number.MAX_SAFE_INTEGER] +safeDecrement :: Int -> Int +safeDecrement i = if i <= minSafeInteger then maxSafeInteger else i - 1 + +#ifdef __GHCJS__ + +foreign import javascript unsafe + "Number.MAX_SAFE_INTEGER" + js_maxSafeInteger :: Int + +foreign import javascript unsafe + "Number.MIN_SAFE_INTEGER" + js_minSafeInteger :: Int + +#else + +js_maxSafeInteger :: Int +js_maxSafeInteger = 0 + +js_minSafeInteger :: Int +js_minSafeInteger = 0 + +#endif diff --git a/javascript-extras/src/JavaScript/Extras/Property.hs b/javascript-extras/src/JavaScript/Extras/Property.hs new file mode 100644 index 0000000..1577ee1 --- /dev/null +++ b/javascript-extras/src/JavaScript/Extras/Property.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE TupleSections #-} + +module JavaScript.Extras.Property + ( classNames + , Property + , getProperty + , setProperty + , fromProperties + , toProperties + ) where + +import Control.DeepSeq +import Control.Parallel +import qualified Data.JSString as JS +import qualified GHC.Exts as Exts +import qualified GHCJS.Marshal.Pure as J +import qualified GHCJS.Types as J +import qualified JavaScript.Extras.Cast as JE +import qualified JavaScript.Extras.JSRep as JE +import qualified JavaScript.Object as JO +import qualified JavaScript.Object.Internal as JOI +import Unsafe.Coerce + +type Property = (J.JSString, JE.JSRep) + +-- | Creates a JE.JSRep single string for "className" property from a list of (JSString, Bool) +-- Idea from https://github.com/JedWatson/classnames +classNames :: [(J.JSString, Bool)] -> JE.JSRep +classNames = JE.toJSR . JS.unwords . fmap fst . filter snd + +-- | get a property of any JSVal. If a null or undefined is queried, the result will also be null +getProperty :: JE.ToJS j => J.JSString -> j -> IO JE.JSRep +getProperty k j = let k' = J.pToJSVal k + x = JE.toJS j + in if J.isUndefined x || J.isNull x + || J.isUndefined k' || J.isNull k' + then pure $ JE.JSRep J.nullRef + else js_unsafeGetProperty k x + +-- | set a property of any JSVal +setProperty :: JE.ToJS j => Property -> j -> IO () +setProperty (k, v) j = let k' = J.pToJSVal k + x = JE.toJS j + in if J.isUndefined x || J.isNull x + || J.isUndefined k' || J.isNull k' + then pure () + else js_unsafeSetProperty k v x + +fromProperties :: [Property] -> JO.Object +fromProperties xs = + let (names, values) = unzip xs + in (rnf names `seq` rnf values) `pseq` js_toJSObjectPure (unsafeCoerce names) (unsafeCoerce values) + + +toProperties :: JO.Object -> IO [Property] +toProperties obj = do + props <- JO.listProps obj + traverse (\k -> (\v -> (k, JE.JSRep v)) <$> JO.unsafeGetProp k obj) props + +#ifdef __GHCJS__ + +-- | throws an exception if undefined or null +foreign import javascript unsafe + "$2[$1]" + js_unsafeGetProperty :: J.JSString -> J.JSVal -> IO JE.JSRep + +-- | throws an exception if undefined or null +foreign import javascript unsafe + "$3[$1] = $2;" + js_unsafeSetProperty :: J.JSString -> JE.JSRep -> J.JSVal -> IO () + +-- | zip list of string and JSVal to object, lists must have been completely forced first +-- Using the idea from JavaScript.Array.Internal.fromList h$fromHsListJSVal +foreign import javascript unsafe + "hje$fromHsZipListJSVal($1, $2)" + js_toJSObjectPure :: Exts.Any -> Exts.Any -> JO.Object + +#else + +-- | throws an exception if undefined or null +js_unsafeGetProperty :: J.JSString -> J.JSVal -> IO JE.JSRep +js_unsafeGetProperty _ _ = pure $ JE.JSRep J.nullRef + +-- | throws an exception if undefined or null +js_unsafeSetProperty :: J.JSString -> JE.JSRep -> J.JSVal -> IO () +js_unsafeSetProperty _ _ _ = pure () + +-- | zip list of string and JSVal to object, lists must have been completely forced first +-- Using the idea from JavaScript.Array.Internal.fromList h$fromHsListJSVal +js_toJSObjectPure :: Exts.Any -> Exts.Any -> JO.Object +js_toJSObjectPure _ _ = JOI.Object J.nullRef + +#endif diff --git a/javascript-extras/test/hs/Main.hs b/javascript-extras/test/hs/Main.hs new file mode 100644 index 0000000..0c8395b --- /dev/null +++ b/javascript-extras/test/hs/Main.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +#ifdef __GHCJS__ + +import qualified Data.JSString as JS +import qualified GHCJS.Foreign.Callback as J +import qualified GHCJS.Types as J +import qualified JavaScript.Extras as JE +import JavaScript.Extras.JSRep.Unsafe () + +test :: JE.JSRep -> IO () +test x = do + let str = show x + x' = read str :: JE.JSRep + str' = show x' + js_write $ "Test: " `mappend` (JS.pack str) `mappend` " == " `mappend` (JS.pack str') + +main :: IO () +main = do + test js_int + test js_obj + cb <- J.syncCallback' (pure (JE.toJS js_int)) + test (JE.JSRep (J.jsval cb)) + J.releaseCallback cb + test (JE.JSRep (J.jsval cb)) + +foreign import javascript unsafe + "document.write('

' + $1 + '

')" + js_write :: JS.JSString -> IO () + +foreign import javascript unsafe + "5" + js_int :: JE.JSRep + +foreign import javascript unsafe + "{ 'hello': 'world' }" + js_obj :: JE.JSRep + +#else + +main :: IO () +main = pure () + +#endif