diff --git a/jsaddle.cabal b/jsaddle.cabal --- a/jsaddle.cabal +++ b/jsaddle.cabal @@ -1,5 +1,5 @@ name: jsaddle -version: 0.7.0.0 +version: 0.8.0.0 cabal-version: >=1.10 build-type: Simple license: MIT @@ -40,23 +40,48 @@ unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.12 exposed-modules: + Data.JSString + Data.JSString.Internal + Data.JSString.Internal.Fusion + Data.JSString.Internal.Fusion.CaseMapping + Data.JSString.Internal.Fusion.Common + Data.JSString.Internal.Fusion.Types + Data.JSString.Internal.Search + Data.JSString.Internal.Type + Data.JSString.Text + GHCJS.Prim + GHCJS.Prim.Internal + GHCJS.Types + GHCJS.Foreign + GHCJS.Foreign.Internal + GHCJS.Internal.Types GHCJS.Marshal GHCJS.Marshal.Internal GHCJS.Marshal.Pure + GHCJS.Buffer + GHCJS.Buffer.Types + JavaScript.TypedArray + JavaScript.TypedArray.ArrayBuffer + JavaScript.TypedArray.ArrayBuffer.Internal + JavaScript.TypedArray.ArrayBuffer.Type + JavaScript.TypedArray.DataView.Internal + JavaScript.TypedArray.Immutable + JavaScript.TypedArray.Internal + JavaScript.TypedArray.Internal.Types + JavaScript.Array JavaScript.Array.Internal + JavaScript.Object JavaScript.Object.Internal Language.Javascript.JSaddle.Native Language.Javascript.JSaddle.Native.Internal hs-source-dirs: src-ghc exposed-modules: Language.Javascript.JSaddle - Language.Javascript.JSaddle.Array Language.Javascript.JSaddle.Arguments Language.Javascript.JSaddle.Classes Language.Javascript.JSaddle.Classes.Internal Language.Javascript.JSaddle.Evaluate Language.Javascript.JSaddle.Exception - Language.Javascript.JSaddle.Foreign Language.Javascript.JSaddle.Marshal.String Language.Javascript.JSaddle.Monad Language.Javascript.JSaddle.Object @@ -69,10 +94,10 @@ build-depends: aeson >=0.8.0.2 && <1.1, base <5, + base64-bytestring >=1.0.0.1 && <1.1, bytestring >=0.10.6.0 && <0.11, lens >=3.8.5 && <4.16, primitive >=0.6.1.0 && <0.7, - template-haskell -any, text >=1.2.1.3 && <1.3, transformers >=0.4.2.0 && <0.6 default-language: Haskell2010 diff --git a/src-ghc/Data/JSString.hs b/src-ghc/Data/JSString.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString.hs @@ -0,0 +1,1404 @@ +{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| Manipulation of JavaScript strings, API and fusion implementation + based on Data.Text by Tom Harper, Duncan Coutts, Bryan O'Sullivan e.a. + -} +module Data.JSString ( JSString + + -- * Creation and elimination + , pack + , unpack, unpack' + , singleton + , empty + + -- * Basic interface + , cons + , snoc + , append + , uncons + , head + , last + , tail + , init + , null + , length + , compareLength + + -- * Transformations + , map + , intercalate + , intersperse + , transpose + , reverse + , replace + + -- ** Case conversion + , toCaseFold + , toLower + , toUpper + , toTitle + + -- ** Justification + , justifyLeft + , justifyRight + , center + + -- * Folds + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , any + , all + , maximum + , minimum + + -- * Construction + + -- ** Scans + , scanl + , scanl1 + , scanr + , scanr1 + + -- ** Accumulating maps + , mapAccumL + , mapAccumR + + -- ** Generation and unfolding + , replicate + , unfoldr + , unfoldrN + + -- * Substrings + + -- ** Breaking strings + , take + , takeEnd + , drop + , dropEnd + , takeWhile + , dropWhile + , dropWhileEnd + , dropAround + , strip + , stripStart + , stripEnd + , splitAt + , breakOn + , breakOnEnd + , break + , span + , group + , group' + , groupBy + , inits + , tails + + -- ** Breaking into many substrings + , splitOn, splitOn' + , split + , chunksOf, chunksOf' + + -- ** Breaking into lines and words + , lines, lines' + , words, words' + , unlines + , unwords + + -- * Predicates + , isPrefixOf + , isSuffixOf + , isInfixOf + + -- ** View patterns + , stripPrefix + , stripSuffix + , commonPrefixes + + -- * Searching + , filter + , breakOnAll, breakOnAll' + , find + , partition + + -- * Indexing + , index + , findIndex + , count + + -- * Zipping + , zip + , zipWith + ) where + +import Prelude + ( Char, Bool(..), Int, Maybe(..), String, Eq(..), Ord(..), Ordering(..), (++) + , Read(..), Show(..), (&&), (||), (+), (-), (.), ($), ($!), (>>) + , not, seq, return, otherwise, quot) +import qualified Prelude as P + +import Control.DeepSeq (NFData(..)) +import Data.Char (isSpace) +import Data.Coerce (coerce) +import qualified Data.List as L +import Data.Data +import qualified Data.Text as T +import qualified Data.Text.Internal.Fusion as TF +import qualified Data.Text.Internal.Fusion.Common as TF + +import GHC.Exts + ( Int#, (+#), (-#), (>=#), (>#), isTrue#, chr#, Char(..) + , Int(..), Addr#, tagToEnum#) +import qualified GHC.Exts as Exts +import qualified GHC.CString as GHC + +import Unsafe.Coerce + +import GHCJS.Prim (JSVal) + +import Data.JSString.Internal.Type +import Data.JSString.Internal.Fusion (stream, unstream) +import qualified Data.JSString.Internal.Fusion as S +import qualified Data.JSString.Internal.Fusion.Common as S + +instance Exts.IsList JSString where + type Item JSString = Char + fromList = pack + toList = unpack + +-- ----------------------------------------------------------------------------- +-- * Conversion to/from 'JSString' + +-- | /O(n)/ Convert a 'String' into a 'JSString'. Subject to +-- fusion. +pack :: String -> JSString +pack = coerce T.pack +{-# INLINE [1] pack #-} + +{-# RULES +"JSSTRING pack -> fused" [~1] forall x. + pack x = unstream (S.map safe (S.streamList x)) +"JSSTRING pack -> unfused" [1] forall x. + unstream (S.map safe (S.streamList x)) = pack x + #-} + +-- | /O(n)/ Convert a 'JSString' into a 'String'. Subject to fusion. +unpack :: JSString -> String +unpack = S.unstreamList . stream +{-# INLINE [1] unpack #-} + +unpack' :: JSString -> String +unpack' = coerce T.unpack +{-# INLINE unpack' #-} + +-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion. +unpackCString# :: Addr# -> JSString +unpackCString# = coerce T.unpackCString# +{-# NOINLINE unpackCString# #-} + +{-# RULES "JSSTRING literal" forall a. + unstream (S.map safe (S.streamList (GHC.unpackCString# a))) + = unpackCString# a #-} + +{-# RULES "JSSTRING literal UTF8" forall a. + unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a))) + = unpackCString# a #-} + +{-# RULES "JSSTRING empty literal" + unstream (S.map safe (S.streamList [])) + = empty_ #-} + +{-# RULES "JSSTRING singleton literal" forall a. + unstream (S.map safe (S.streamList [a])) + = singleton a #-} + + +-- | /O(1)/ Convert a character into a 'JSString'. Subject to fusion. +-- Performs replacement on invalid scalar values. +singleton :: Char -> JSString +singleton = coerce T.singleton +{-# INLINE [1] singleton #-} + +{-# RULES +"JSSTRING singleton -> fused" [~1] forall a. + singleton a = unstream (S.singleton (safe a)) +"JSSTRING singleton -> unfused" [1] forall a. + unstream (S.singleton (safe a)) = singleton a + #-} + +-- This is intended to reduce inlining bloat. +-- singleton_ :: Char -> Text +-- singleton_ c = js_singleton c + +-- Text (A.run x) 0 len +-- where x :: ST s (A.MArray s) +-- x = do arr <- A.new len +-- _ <- unsafeWrite arr 0 d +-- return arr +-- len | d < '\x10000' = 1 +-- x | otherwise = 2 +-- d = safe c +-- {-# NOINLINE singleton_ #-} + +-- ----------------------------------------------------------------------------- +-- * Basic functions + +-- | /O(n)/ Adds a character to the front of a 'JSString'. This function +-- is more costly than its 'List' counterpart because it requires +-- copying a new array. Subject to fusion. Performs replacement on +-- invalid scalar values. +cons :: Char -> JSString -> JSString +cons = coerce T.cons +{-# INLINE [1] cons #-} + +{-# RULES +"JSSTRING cons -> fused" [~1] forall c x. + cons c x = unstream (S.cons (safe c) (stream x)) +"JSSTRING cons -> unfused" [1] forall c x. + unstream (S.cons (safe c) (stream x)) = cons c x + #-} + +infixr 5 `cons` + +-- | /O(n)/ Adds a character to the end of a 'JSString'. This copies the +-- entire array in the process, unless fused. Subject to fusion. +-- Performs replacement on invalid scalar values. +snoc :: JSString -> Char -> JSString +snoc = coerce T.snoc + -- unstream (S.snoc (stream t) (safe c)) +{-# INLINE [1] snoc #-} + +{-# RULES +"JSSTRING snoc -> fused" [~1] forall x c. + snoc x c = unstream (S.snoc (stream x) (safe c)) +"JSSTRING snoc -> unfused" [1] forall x c. + unstream (S.snoc (stream x) (safe c)) = snoc x c + #-} + +-- | /O(n)/ Appends one 'JSString' to the other by copying both of them +-- into a new 'JSString'. Subject to fusion. +append :: JSString -> JSString -> JSString +append = coerce T.append +{-# INLINE [1] append #-} + +{-# RULES +"JSSTRING append -> fused" [~1] forall x1 x2. + append x1 x2 = unstream (S.append (stream x1) (stream x2)) +"JSSTRING append -> unfused" [1] forall x1 x2. + unstream (S.append (stream x1) (stream x2)) = append x1 x2 + #-} + +-- | /O(1)/ Returns the first character of a 'JSString', which must be +-- non-empty. Subject to fusion. +head :: JSString -> Char +head = coerce T.head +{-# INLINE [1] head #-} + +{-# RULES +"JSSTRING head -> fused" [~1] forall x. + head x = S.head (stream x) +"JSSTRING head -> unfused" [1] forall x. + S.head (stream x) = head x + #-} + + +-- | /O(1)/ Returns the first character and rest of a 'JSString', or +-- 'Nothing' if empty. Subject to fusion. +uncons :: JSString -> Maybe (Char, JSString) +uncons = coerce T.uncons +{-# INLINE [1] uncons #-} + +-- | Lifted from Control.Arrow and specialized. +second :: (b -> c) -> (a,b) -> (a,c) +second f (a, b) = (a, f b) + +-- | /O(1)/ Returns the last character of a 'JSString', which must be +-- non-empty. Subject to fusion. +last :: JSString -> Char +last = coerce T.last +{-# INLINE [1] last #-} + +{-# RULES +"JSSTRING last -> fused" [~1] forall x. + last x = S.last (stream x) +"JSSTRING last -> unfused" [1] forall x. + S.last (stream x) = last x + #-} + +-- | /O(1)/ Returns all characters after the head of a 'JSString', which +-- must be non-empty. Subject to fusion. +tail :: JSString -> JSString +tail = coerce T.tail +{-# INLINE [1] tail #-} + +{-# RULES +"JSSTRING tail -> fused" [~1] forall x. + tail x = unstream (S.tail (stream x)) +"JSSTRING tail -> unfused" [1] forall x. + unstream (S.tail (stream x)) = tail x + #-} + +-- | /O(1)/ Returns all but the last character of a 'JSString', which must +-- be non-empty. Subject to fusion. +init :: JSString -> JSString +init = coerce T.init +{-# INLINE [1] init #-} + +{-# RULES +"JSSTRING init -> fused" [~1] forall t. + init t = unstream (S.init (stream t)) +"JSSTRING init -> unfused" [1] forall t. + unstream (S.init (stream t)) = init t + #-} + +-- | /O(1)/ Tests whether a 'JSString' is empty or not. Subject to +-- fusion. +null :: JSString -> Bool +null = coerce T.null +{-# INLINE [1] null #-} + +{-# RULES +"JSSTRING null -> fused" [~1] forall t. + null t = S.null (stream t) +"JSSTRING null -> unfused" [1] forall t. + S.null (stream t) = null t + #-} + +-- | /O(n)/ Returns the number of characters in a 'JSString'. +-- Subject to fusion. +length :: JSString -> Int +length = coerce T.length +{-# INLINE [1] length #-} + +{-# RULES +"JSSTRING length -> fused" [~1] forall x. + length x = S.length (stream x) +"JSSTRING length -> unfused" [1] forall x. + S.length (stream x) = length x + #-} + +-- | /O(n)/ Compare the count of characters in a 'JSString' to a number. +-- Subject to fusion. +-- +-- This function gives the same answer as comparing against the result +-- of 'length', but can short circuit if the count of characters is +-- greater than the number, and hence be more efficient. +compareLength :: JSString -> Int -> Ordering +compareLength = coerce T.compareLength +{-# INLINE [1] compareLength #-} + +{-# RULES +"JSSTRING compareN/length -> compareLength" [~1] forall t n. + compare (length t) n = compareLength t n + #-} + +{-# RULES +"JSSTRING ==N/length -> compareLength/==EQ" [~1] forall t n. + (==) (length t) n = compareLength t n == EQ + #-} + +{-# RULES +"JSSTRING /=N/length -> compareLength//=EQ" [~1] forall t n. + (/=) (length t) n = compareLength t n /= EQ + #-} + +{-# RULES +"JSSTRING compareLength/==LT" [~1] forall t n. + (<) (length t) n = compareLength t n == LT + #-} + +{-# RULES +"JSSTRING <=N/length -> compareLength//=GT" [~1] forall t n. + (<=) (length t) n = compareLength t n /= GT + #-} + +{-# RULES +"JSSTRING >N/length -> compareLength/==GT" [~1] forall t n. + (>) (length t) n = compareLength t n == GT + #-} + +{-# RULES +"JSSTRING >=N/length -> compareLength//=LT" [~1] forall t n. + (>=) (length t) n = compareLength t n /= LT + #-} + +-- ----------------------------------------------------------------------------- +-- * Transformations +-- | /O(n)/ 'map' @f@ @t@ is the 'JSString' obtained by applying @f@ to +-- each element of @t@. Subject to fusion. Performs replacement on +-- invalid scalar values. +map :: (Char -> Char) -> JSString -> JSString +map = coerce T.map +{-# INLINE [1] map #-} + +-- | /O(n)/ The 'intercalate' function takes a 'JSString' and a list of +-- 'JSString's and concatenates the list after interspersing the first +-- argument between each element of the list. +intercalate :: JSString -> [JSString] -> JSString +intercalate = coerce T.intercalate +{-# INLINE [1] intercalate #-} + +-- | /O(n)/ The 'intersperse' function takes a character and places it +-- between the characters of a 'JSString'. Subject to fusion. Performs +-- replacement on invalid scalar values. +intersperse :: Char -> JSString -> JSString +intersperse = coerce T.intersperse +{-# INLINE [1] intersperse #-} + +{-# RULES +"JSSTRING intersperse -> fused" [~1] forall c x. + intersperse c x = unstream (S.intersperse (safe c) (stream x)) +"JSSTRING intersperse -> unfused" [1] forall c x. + unstream (S.intersperse (safe c) (stream x)) = intersperse c x + #-} + +-- | /O(n)/ Reverse the characters of a string. Subject to fusion. +reverse :: JSString -> JSString +reverse = coerce T.reverse +{-# INLINE [1] reverse #-} + +{-# RULES +"JSSTRING reverse -> fused" [~1] forall x. + reverse x = S.reverse (stream x) +"JSSTRING reverse -> unfused" [1] forall x. + S.reverse (stream x) = reverse x + #-} + +-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in +-- @haystack@ with @replacement@. +-- +-- This function behaves as though it was defined as follows: +-- +-- @ +-- replace needle replacement haystack = +-- 'intercalate' replacement ('splitOn' needle haystack) +-- @ +-- +-- As this suggests, each occurrence is replaced exactly once. So if +-- @needle@ occurs in @replacement@, that occurrence will /not/ itself +-- be replaced recursively: +-- +-- > replace "oo" "foo" "oo" == "foo" +-- +-- In cases where several instances of @needle@ overlap, only the +-- first one will be replaced: +-- +-- > replace "ofo" "bar" "ofofo" == "barfo" +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +replace :: JSString + -- ^ @needle@ to search for. If this string is empty, an + -- error will occur. + -> JSString + -- ^ @replacement@ to replace @needle@ with. + -> JSString + -- ^ @haystack@ in which to search. + -> JSString +replace = coerce T.replace +{-# INLINE replace #-} + +-- ---------------------------------------------------------------------------- +-- ** Case conversions (folds) + +-- $case +-- +-- When case converting 'JSString' values, do not use combinators like +-- @map toUpper@ to case convert each character of a string +-- individually, as this gives incorrect results according to the +-- rules of some writing systems. The whole-string case conversion +-- functions from this module, such as @toUpper@, obey the correct +-- case conversion rules. As a result, these functions may map one +-- input character to two or three output characters. For examples, +-- see the documentation of each function. +-- +-- /Note/: In some languages, case conversion is a locale- and +-- context-dependent operation. The case conversion functions in this +-- module are /not/ locale sensitive. Programs that require locale +-- sensitivity should use appropriate versions of the +-- . + +-- | /O(n)/ Convert a string to folded case. Subject to fusion. +-- +-- This function is mainly useful for performing caseless (also known +-- as case insensitive) string comparisons. +-- +-- A string @x@ is a caseless match for a string @y@ if and only if: +-- +-- @toCaseFold x == toCaseFold y@ +-- +-- The result string may be longer than the input string, and may +-- differ from applying 'toLower' to the input string. For instance, +-- the Armenian small ligature \"ﬓ\" (men now, U+FB13) is case +-- folded to the sequence \"մ\" (men, U+0574) followed by +-- \"ն\" (now, U+0576), while the Greek \"µ\" (micro sign, +-- U+00B5) is case folded to \"μ\" (small letter mu, U+03BC) +-- instead of itself. +toCaseFold :: JSString -> JSString +toCaseFold = coerce T.toCaseFold +{-# INLINE [0] toCaseFold #-} + +-- | /O(n)/ Convert a string to lower case, using simple case +-- conversion. Subject to fusion. +-- +-- The result string may be longer than the input string. For +-- instance, \"İ\" (Latin capital letter I with dot above, +-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069) +-- followed by \" ̇\" (combining dot above, U+0307). +toLower :: JSString -> JSString +toLower = coerce T.toLower +{-# INLINE [1] toLower #-} + +{-# RULES +"JSSTRING toLower -> fused" [~1] forall x. + toLower x = unstream (S.toLower (stream x)) +"JSSTRING toLower -> unfused" [1] forall x. + unstream (S.toLower (stream x)) = toLower x + #-} + +-- | /O(n)/ Convert a string to upper case, using simple case +-- conversion. Subject to fusion. +-- +-- The result string may be longer than the input string. For +-- instance, the German \"ß\" (eszett, U+00DF) maps to the +-- two-letter sequence \"SS\". +toUpper :: JSString -> JSString +toUpper = coerce T.toUpper +{-# INLINE [1] toUpper #-} + +{-# RULES +"JSSTRING toUpper -> fused" [~1] forall x. + toUpper x = unstream (S.toUpper(stream x)) +"JSSTRING toUpper -> unfused" [1] forall x. + unstream (S.toUpper (stream x)) = toUpper x + #-} + +-- | /O(n)/ Convert a string to title case, using simple case +-- conversion. Subject to fusion. +-- +-- The first letter of the input is converted to title case, as is +-- every subsequent letter that immediately follows a non-letter. +-- Every letter that immediately follows another letter is converted +-- to lower case. +-- +-- The result string may be longer than the input string. For example, +-- the Latin small ligature fl (U+FB02) is converted to the +-- sequence Latin capital letter F (U+0046) followed by Latin small +-- letter l (U+006C). +-- +-- /Note/: this function does not take language or culture specific +-- rules into account. For instance, in English, different style +-- guides disagree on whether the book name \"The Hill of the Red +-- Fox\" is correctly title cased—but this function will +-- capitalize /every/ word. +toTitle :: JSString -> JSString +toTitle = coerce T.toTitle +{-# INLINE toTitle #-} + +-- | /O(n)/ Left-justify a string to the given length, using the +-- specified fill character on the right. Subject to fusion. +-- Performs replacement on invalid scalar values. +-- +-- Examples: +-- +-- > justifyLeft 7 'x' "foo" == "fooxxxx" +-- > justifyLeft 3 'x' "foobar" == "foobar" +justifyLeft :: Int -> Char -> JSString -> JSString +justifyLeft = coerce T.justifyLeft +{-# INLINE [1] justifyLeft #-} + +{-# RULES +"JSSTRING justifyLeft -> fused" [~1] forall k c t. + justifyLeft k c t = unstream (S.justifyLeftI k c (stream t)) +"JSSTRING justifyLeft -> unfused" [1] forall k c t. + unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t + #-} + +-- | /O(n)/ Right-justify a string to the given length, using the +-- specified fill character on the left. Performs replacement on +-- invalid scalar values. +-- +-- Examples: +-- +-- > justifyRight 7 'x' "bar" == "xxxxbar" +-- > justifyRight 3 'x' "foobar" == "foobar" +justifyRight :: Int -> Char -> JSString -> JSString +justifyRight = coerce T.justifyRight +{-# INLINE justifyRight #-} + +-- | /O(n)/ Center a string to the given length, using the specified +-- fill character on either side. Performs replacement on invalid +-- scalar values. +-- +-- Examples: +-- +-- > center 8 'x' "HS" = "xxxHSxxx" +center :: Int -> Char -> JSString -> JSString +center = coerce T.center +{-# INLINE center #-} + +-- | /O(n)/ The 'transpose' function transposes the rows and columns +-- of its 'JSString' argument. Note that this function uses 'pack', +-- 'unpack', and the list version of transpose, and is thus not very +-- efficient. +transpose :: [JSString] -> [JSString] +transpose = coerce T.transpose + +-- ----------------------------------------------------------------------------- +-- * Reducing 'JSString's (folds) + +-- | /O(n)/ 'foldl', applied to a binary operator, a starting value +-- (typically the left-identity of the operator), and a 'JSString', +-- reduces the 'JSString' using the binary operator, from left to right. +-- Subject to fusion. +foldl :: (a -> Char -> a) -> a -> JSString -> a +foldl f = coerce (T.foldl f) +{-# INLINE foldl #-} + +-- | /O(n)/ A strict version of 'foldl'. Subject to fusion. +foldl' :: (a -> Char -> a) -> a -> JSString -> a +foldl' f = coerce (T.foldl' f) +{-# INLINE foldl' #-} + +-- | /O(n)/ A variant of 'foldl' that has no starting value argument, +-- and thus must be applied to a non-empty 'JSString'. Subject to fusion. +foldl1 :: (Char -> Char -> Char) -> JSString -> Char +foldl1 = coerce T.foldl1 +{-# INLINE foldl1 #-} + +-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion. +foldl1' :: (Char -> Char -> Char) -> JSString -> Char +foldl1' = coerce T.foldl1' +{-# INLINE foldl1' #-} + +-- | /O(n)/ 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a 'JSString', +-- reduces the 'JSString' using the binary operator, from right to left. +-- Subject to fusion. +foldr :: (Char -> a -> a) -> a -> JSString -> a +foldr f = coerce (T.foldr f) +{-# INLINE foldr #-} + +-- | /O(n)/ A variant of 'foldr' that has no starting value argument, +-- and thus must be applied to a non-empty 'JSString'. Subject to +-- fusion. +foldr1 :: (Char -> Char -> Char) -> JSString -> Char +foldr1 = coerce T.foldr1 +{-# INLINE foldr1 #-} + +-- ----------------------------------------------------------------------------- +-- ** Special folds + +-- | /O(n)/ Concatenate a list of 'JSString's. +concat :: [JSString] -> JSString +concat = coerce T.concat + +-- | /O(n)/ Map a function over a 'JSString' that results in a 'JSString', and +-- concatenate the results. +concatMap :: (Char -> JSString) -> JSString -> JSString +concatMap = coerce T.concatMap +{-# INLINE concatMap #-} + +-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the +-- 'JSString' @t@ satisifes the predicate @p@. Subject to fusion. +any :: (Char -> Bool) -> JSString -> Bool +any = coerce T.any +{-# INLINE any #-} + +-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the +-- 'JSString' @t@ satisify the predicate @p@. Subject to fusion. +all :: (Char -> Bool) -> JSString -> Bool +all = coerce T.all +{-# INLINE all #-} + +-- | /O(n)/ 'maximum' returns the maximum value from a 'JSString', which +-- must be non-empty. Subject to fusion. +maximum :: JSString -> Char +maximum = coerce T.maximum +{-# INLINE maximum #-} + +-- | /O(n)/ 'minimum' returns the minimum value from a 'JSString', which +-- must be non-empty. Subject to fusion. +minimum :: JSString -> Char +minimum = coerce T.minimum +{-# INLINE minimum #-} + +-- ----------------------------------------------------------------------------- +-- * Building 'JSString's + +-- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of +-- successive reduced values from the left. Subject to fusion. +-- Performs replacement on invalid scalar values. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: (Char -> Char -> Char) -> Char -> JSString -> JSString +scanl = coerce T.scanl +{-# INLINE scanl #-} + +-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting +-- value argument. Subject to fusion. Performs replacement on +-- invalid scalar values. +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (Char -> Char -> Char) -> JSString -> JSString +scanl1 = coerce T.scanl1 +{-# INLINE scanl1 #-} + +-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs +-- replacement on invalid scalar values. +-- +-- > scanr f v == reverse . scanl (flip f) v . reverse +scanr :: (Char -> Char -> Char) -> Char -> JSString -> JSString +scanr = coerce T.scanr +{-# INLINE scanr #-} + +-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting +-- value argument. Subject to fusion. Performs replacement on +-- invalid scalar values. +scanr1 :: (Char -> Char -> Char) -> JSString -> JSString +scanr1 = coerce T.scanr1 +{-# INLINE scanr1 #-} + +-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a +-- function to each element of a 'JSString', passing an accumulating +-- parameter from left to right, and returns a final 'JSString'. Performs +-- replacement on invalid scalar values. +mapAccumL :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString) +mapAccumL f = coerce (T.mapAccumL f) +{-# INLINE mapAccumL #-} + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- a strict 'foldr'; it applies a function to each element of a +-- 'JSString', passing an accumulating parameter from right to left, and +-- returning a final value of this accumulator together with the new +-- 'JSString'. +-- Performs replacement on invalid scalar values. +mapAccumR :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString) +mapAccumR f = coerce (T.mapAccumR f) +{-# INLINE mapAccumR #-} + +-- ----------------------------------------------------------------------------- +-- ** Generating and unfolding 'JSString's + +-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'JSString' consisting of the input +-- @t@ repeated @n@ times. +replicate :: Int -> JSString -> JSString +replicate = coerce T.replicate +{-# INLINE [1] replicate #-} + +-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr' +-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a +-- 'JSString' from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the 'JSString', otherwise +-- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the +-- string, and @b@ is the seed value for further production. Subject +-- to fusion. Performs replacement on invalid scalar values. +unfoldr :: (a -> Maybe (Char,a)) -> a -> JSString +unfoldr f = coerce (T.unfoldr f) +{-# INLINE unfoldr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'JSString' from a seed +-- value. However, the length of the result should be limited by the +-- first argument to 'unfoldrN'. This function is more efficient than +-- 'unfoldr' when the maximum length of the result is known and +-- correct, otherwise its performance is similar to 'unfoldr'. Subject +-- to fusion. Performs replacement on invalid scalar values. +unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> JSString +unfoldrN n f = coerce (T.unfoldrN n f) +{-# INLINE unfoldrN #-} + +-- ----------------------------------------------------------------------------- +-- * Substrings + +-- | /O(n)/ 'take' @n@, applied to a 'JSString', returns the prefix of the +-- 'JSString' of length @n@, or the 'JSString' itself if @n@ is greater than +-- the length of the JSString. Subject to fusion. +take :: Int -> JSString -> JSString +take = coerce T.take +{-# INLINE [1] take #-} +{- +iterN :: Int -> JSString -> Int +iterN n t@(Text _arr _off len) = loop 0 0 + where loop !i !cnt + | i >= len || cnt >= n = i + | otherwise = loop (i+d) (cnt+1) + where d = iter_ t i +-} +{-# RULES +"JSSTRING take -> fused" [~1] forall n t. + take n t = unstream (S.take n (stream t)) +"JSSTRING take -> unfused" [1] forall n t. + unstream (S.take n (stream t)) = take n t + #-} + +-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after +-- taking @n@ characters from the end of @t@. +-- +-- Examples: +-- +-- > takeEnd 3 "foobar" == "bar" +takeEnd :: Int -> JSString -> JSString +takeEnd = coerce T.takeEnd + +-- | /O(n)/ 'drop' @n@, applied to a 'JSString', returns the suffix of the +-- 'JSString' after the first @n@ characters, or the empty 'JSString' if @n@ +-- is greater than the length of the 'JSString'. Subject to fusion. +drop :: Int -> JSString -> JSString +drop = coerce T.drop +{-# INLINE [1] drop #-} + +{-# RULES +"JSSTRING drop -> fused" [~1] forall n t. + drop n t = unstream (S.drop n (stream t)) +"JSSTRING drop -> unfused" [1] forall n t. + unstream (S.drop n (stream t)) = drop n t + #-} + +-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after +-- dropping @n@ characters from the end of @t@. +-- +-- Examples: +-- +-- > dropEnd 3 "foobar" == "foo" +dropEnd :: Int -> JSString -> JSString +dropEnd = coerce T.dropEnd + +-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'JSString', +-- returns the longest prefix (possibly empty) of elements that +-- satisfy @p@. Subject to fusion. +takeWhile :: (Char -> Bool) -> JSString -> JSString +takeWhile = coerce T.takeWhile +{-# INLINE [1] takeWhile #-} + +{-# RULES +"TEXT takeWhile -> fused" [~1] forall p t. + takeWhile p t = unstream (S.takeWhile p (stream t)) +"TEXT takeWhile -> unfused" [1] forall p t. + unstream (S.takeWhile p (stream t)) = takeWhile p t + #-} + +-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after +-- 'takeWhile' @p@ @t@. Subject to fusion. +dropWhile :: (Char -> Bool) -> JSString -> JSString +dropWhile = coerce T.dropWhile +{-# INLINE [1] dropWhile #-} + +{-# RULES +"TEXT dropWhile -> fused" [~1] forall p t. + dropWhile p t = unstream (S.dropWhile p (stream t)) +"TEXT dropWhile -> unfused" [1] forall p t. + unstream (S.dropWhile p (stream t)) = dropWhile p t + #-} + +-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after +-- dropping characters that fail the predicate @p@ from the end of +-- @t@. Subject to fusion. +-- Examples: +-- +-- > dropWhileEnd (=='.') "foo..." == "foo" +dropWhileEnd :: (Char -> Bool) -> JSString -> JSString +dropWhileEnd = coerce T.dropWhileEnd +{-# INLINE [1] dropWhileEnd #-} + +{-# RULES +"TEXT dropWhileEnd -> fused" [~1] forall p t. + dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t)) +"TEXT dropWhileEnd -> unfused" [1] forall p t. + S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t + #-} + +-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after +-- dropping characters that fail the predicate @p@ from both the +-- beginning and end of @t@. Subject to fusion. +dropAround :: (Char -> Bool) -> JSString -> JSString +dropAround = coerce T.dropAround +{-# INLINE [1] dropAround #-} + +-- | /O(n)/ Remove leading white space from a string. Equivalent to: +-- +-- > dropWhile isSpace +stripStart :: JSString -> JSString +stripStart = coerce T.stripStart +{-# INLINE [1] stripStart #-} + +-- | /O(n)/ Remove trailing white space from a string. Equivalent to: +-- +-- > dropWhileEnd isSpace +stripEnd :: JSString -> JSString +stripEnd = coerce T.stripEnd +{-# INLINE [1] stripEnd #-} + +-- | /O(n)/ Remove leading and trailing white space from a string. +-- Equivalent to: +-- +-- > dropAround isSpace +strip :: JSString -> JSString +strip = coerce T.strip +{-# INLINE [1] strip #-} + +-- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a +-- prefix of @t@ of length @n@, and whose second is the remainder of +-- the string. It is equivalent to @('take' n t, 'drop' n t)@. +splitAt :: Int -> JSString -> (JSString, JSString) +splitAt = coerce T.splitAt +{-# INLINE splitAt #-} + +-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns +-- a pair whose first element is the longest prefix (possibly empty) +-- of @t@ of elements that satisfy @p@, and whose second is the +-- remainder of the list. +span :: (Char -> Bool) -> JSString -> (JSString, JSString) +span = coerce T.span +{-# INLINE span #-} + +-- | /O(n)/ 'break' is like 'span', but the prefix returned is +-- over elements that fail the predicate @p@. +break :: (Char -> Bool) -> JSString -> (JSString, JSString) +break = coerce T.break +{-# INLINE break #-} + +-- | /O(n)/ Group characters in a string according to a predicate. +groupBy :: (Char -> Char -> Bool) -> JSString -> [JSString] +groupBy = coerce T.groupBy + +-- | /O(n)/ Group characters in a string by equality. +group :: JSString -> [JSString] +group = coerce T.group +{-# INLINE group #-} + +group' :: JSString -> [JSString] +group' = coerce T.group +{-# INLINE group' #-} + +-- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest +-- first. +inits :: JSString -> [JSString] +inits = coerce T.inits + +-- | /O(n^2)/ Return all final segments of the given 'JSString', longest +-- first. +tails :: JSString -> [JSString] +tails = coerce T.tails + +-- $split +-- +-- Splitting functions in this library do not perform character-wise +-- copies to create substrings; they just construct new 'JSString's that +-- are slices of the original. + +-- | /O(m+n)/ Break a 'JSString' into pieces separated by the first 'JSString' +-- argument (which cannot be empty), consuming the delimiter. An empty +-- delimiter is invalid, and will cause an error to be raised. +-- +-- Examples: +-- +-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"] +-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""] +-- > splitOn "x" "x" == ["",""] +-- +-- and +-- +-- > intercalate s . splitOn s == id +-- > splitOn (singleton c) == split (==c) +-- +-- (Note: the string @s@ to split on above cannot be empty.) +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +splitOn :: JSString + -- ^ String to split on. If this string is empty, an error + -- will occur. + -> JSString + -- ^ Input text. + -> [JSString] +splitOn = coerce T.splitOn +{-# INLINE [1] splitOn #-} + +-- RULES +-- "JSSTRING splitOn/singleton -> split/==" [~1] forall c t. +-- splitOn (singleton c) t = split (==c) t +-- + +splitOn' :: JSString + -- ^ String to split on. If this string is empty, an error + -- will occur. + -> JSString + -- ^ Input text. + -> [JSString] +splitOn' = coerce T.splitOn +{-# NOINLINE splitOn' #-} +--- {-# INLINE [1] splitOn' #-} + +-- | /O(n)/ Splits a 'JSString' into components delimited by separators, +-- where the predicate returns True for a separator element. The +-- resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > split (=='a') "aabbaca" == ["","","bb","c",""] +-- > split (=='a') "" == [""] +split :: (Char -> Bool) -> JSString -> [JSString] +split = coerce T.split +{-# INLINE split #-} + +-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last +-- element may be shorter than the other chunks, depending on the +-- length of the input. Examples: +-- +-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"] +-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"] +chunksOf :: Int -> JSString -> [JSString] +chunksOf = coerce T.chunksOf +{-# INLINE chunksOf #-} + +-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last +-- element may be shorter than the other chunks, depending on the +-- length of the input. Examples: +-- +-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"] +-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"] +chunksOf' :: Int -> JSString -> [JSString] +chunksOf' = coerce T.chunksOf +{-# INLINE chunksOf' #-} + +-- ---------------------------------------------------------------------------- +-- * Searching + +------------------------------------------------------------------------------- +-- ** Searching with a predicate + +-- | /O(n)/ The 'find' function takes a predicate and a 'JSString', and +-- returns the first element matching the predicate, or 'Nothing' if +-- there is no such element. +find :: (Char -> Bool) -> JSString -> Maybe Char +find = coerce T.find +{-# INLINE find #-} + +-- | /O(n)/ The 'partition' function takes a predicate and a 'JSString', +-- and returns the pair of 'JSString's with elements which do and do not +-- satisfy the predicate, respectively; i.e. +-- +-- > partition p t == (filter p t, filter (not . p) t) +partition :: (Char -> Bool) -> JSString -> (JSString, JSString) +partition = coerce T.partition +{-# INLINE partition #-} + +-- | /O(n)/ 'filter', applied to a predicate and a 'JSString', +-- returns a 'JSString' containing those characters that satisfy the +-- predicate. +filter :: (Char -> Bool) -> JSString -> JSString +filter = coerce T.filter +{-# INLINE filter #-} + +-- | /O(n+m)/ Find the first instance of @needle@ (which must be +-- non-'null') in @haystack@. The first element of the returned tuple +-- is the prefix of @haystack@ before @needle@ is matched. The second +-- is the remainder of @haystack@, starting with the match. +-- +-- Examples: +-- +-- > breakOn "::" "a::b::c" ==> ("a", "::b::c") +-- > breakOn "/" "foobar" ==> ("foobar", "") +-- +-- Laws: +-- +-- > append prefix match == haystack +-- > where (prefix, match) = breakOn needle haystack +-- +-- If you need to break a string by a substring repeatedly (e.g. you +-- want to break on every instance of a substring), use 'breakOnAll' +-- instead, as it has lower startup overhead. +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +breakOn :: JSString -> JSString -> (JSString, JSString) +breakOn = coerce T.breakOn +{-# INLINE breakOn #-} + +-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the +-- string. +-- +-- The first element of the returned tuple is the prefix of @haystack@ +-- up to and including the last match of @needle@. The second is the +-- remainder of @haystack@, following the match. +-- +-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c") +breakOnEnd :: JSString -> JSString -> (JSString, JSString) +breakOnEnd = coerce T.breakOnEnd +{-# INLINE breakOnEnd #-} + +-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in +-- @haystack@. Each element of the returned list consists of a pair: +-- +-- * The entire string prior to the /k/th match (i.e. the prefix) +-- +-- * The /k/th match, followed by the remainder of the string +-- +-- Examples: +-- +-- > breakOnAll "::" "" +-- > ==> [] +-- > breakOnAll "/" "a/b/c/" +-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")] +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +-- +-- The @needle@ parameter may not be empty. +breakOnAll :: JSString -- ^ @needle@ to search for + -> JSString -- ^ @haystack@ in which to search + -> [(JSString, JSString)] +breakOnAll = coerce T.breakOnAll +{-# INLINE breakOnAll #-} + +breakOnAll' :: JSString -- ^ @needle@ to search for + -> JSString -- ^ @haystack@ in which to search + -> [(JSString, JSString)] +breakOnAll' = coerce T.breakOnAll +{-# INLINE breakOnAll' #-} + +------------------------------------------------------------------------------- +-- ** Indexing 'JSString's + +-- $index +-- +-- If you think of a 'JSString' value as an array of 'Char' values (which +-- it is not), you run the risk of writing inefficient code. +-- +-- An idiom that is common in some languages is to find the numeric +-- offset of a character or substring, then use that number to split +-- or trim the searched string. With a 'JSString' value, this approach +-- would require two /O(n)/ operations: one to perform the search, and +-- one to operate from wherever the search ended. +-- +-- For example, suppose you have a string that you want to split on +-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of +-- searching for the index of @\"::\"@ and taking the substrings +-- before and after that index, you would instead use @breakOnAll \"::\"@. + +-- | /O(n)/ 'JSString' index (subscript) operator, starting from 0. +index :: JSString -> Int -> Char +index = coerce T.index +{-# INLINE index #-} + +-- | /O(n)/ The 'findIndex' function takes a predicate and a 'JSString' +-- and returns the index of the first element in the 'JSString' satisfying +-- the predicate. Subject to fusion. +findIndex :: (Char -> Bool) -> JSString -> Maybe Int +findIndex = coerce T.findIndex +{-# INLINE findIndex #-} + +-- | /O(n+m)/ The 'count' function returns the number of times the +-- query string appears in the given 'JSString'. An empty query string is +-- invalid, and will cause an error to be raised. +-- +-- In (unlikely) bad cases, this function's time complexity degrades +-- towards /O(n*m)/. +count :: JSString -> JSString -> Int +count = coerce T.count +{-# INLINE [1] count #-} + +-- RULES +-- "JSSTRING count/singleton -> countChar" [~1] forall c t. +-- count (singleton c) t = countChar c t +-- + +------------------------------------------------------------------------------- +-- * Zipping + +-- | /O(n)/ 'zip' takes two 'JSString's and returns a list of +-- corresponding pairs of bytes. If one input 'JSString' is short, +-- excess elements of the longer 'JSString' are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: JSString -> JSString -> [(Char,Char)] +zip = coerce T.zip +{-# INLINE [0] zip #-} + +-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function +-- given as the first argument, instead of a tupling function. +-- Performs replacement on invalid scalar values. +zipWith :: (Char -> Char -> Char) -> JSString -> JSString -> JSString +zipWith = coerce T.zipWith +{-# INLINE [0] zipWith #-} + +-- | /O(n)/ Breaks a 'JSString' up into a list of words, delimited by 'Char's +-- representing white space. +words :: JSString -> [JSString] +words = coerce T.words +{-# INLINE words #-} + +-- fixme: strict words' that allocates the whole list in one go +words' :: JSString -> [JSString] +words' = coerce T.words +{-# INLINE words' #-} + +-- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at +-- newline 'Char's. The resulting strings do not contain newlines. +lines :: JSString -> [JSString] +lines = coerce T.lines +{-# INLINE lines #-} + +lines' :: JSString -> [JSString] +lines' = coerce T.lines +{-# INLINE lines' #-} + +{- +-- | /O(n)/ Portably breaks a 'JSString' up into a list of 'JSString's at line +-- boundaries. +-- +-- A line boundary is considered to be either a line feed, a carriage +-- return immediately followed by a line feed, or a carriage return. +-- This accounts for both Unix and Windows line ending conventions, +-- and for the old convention used on Mac OS 9 and earlier. +lines' :: Text -> [Text] +lines' ps | null ps = [] + | otherwise = h : case uncons t of + Nothing -> [] + Just (c,t') + | c == '\n' -> lines t' + | c == '\r' -> case uncons t' of + Just ('\n',t'') -> lines t'' + _ -> lines t' + where (h,t) = span notEOL ps + notEOL c = c /= '\n' && c /= '\r' + +-} + +-- | /O(n)/ Joins lines, after appending a terminating newline to +-- each. +unlines :: [JSString] -> JSString +unlines = coerce T.unlines +{-# INLINE unlines #-} + +-- | /O(n)/ Joins words using single space characters. +unwords :: [JSString] -> JSString +unwords = coerce T.unwords +{-# INLINE unwords #-} + +-- | /O(n)/ The 'isPrefixOf' function takes two 'JSString's and returns +-- 'True' iff the first is a prefix of the second. Subject to fusion. +isPrefixOf :: JSString -> JSString -> Bool +isPrefixOf = coerce T.isPrefixOf +{-# INLINE [1] isPrefixOf #-} + +{-# RULES +"JSSTRING isPrefixOf -> fused" [~1] forall x y. + isPrefixOf x y = S.isPrefixOf (stream x) (stream y) +"JSSTRING isPrefixOf -> unfused" [1] forall x y. + S.isPrefixOf (stream x) (stream y) = isPrefixOf x y + #-} + +-- | /O(n)/ The 'isSuffixOf' function takes two 'JSString's and returns +-- 'True' iff the first is a suffix of the second. +isSuffixOf :: JSString -> JSString -> Bool +isSuffixOf = coerce T.isSuffixOf +{-# INLINE isSuffixOf #-} + +-- | The 'isInfixOf' function takes two 'JSString's and returns +-- 'True' iff the first is contained, wholly and intact, anywhere +-- within the second. +-- +-- Complexity depends on how the JavaScript engine implements +-- String.prototype.find. +isInfixOf :: JSString -> JSString -> Bool +isInfixOf = coerce T.isInfixOf +{-# INLINE [1] isInfixOf #-} + +{-# RULES +"JSSTRING isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h. + isInfixOf (singleton n) h = S.elem n (S.stream h) + #-} + +------------------------------------------------------------------------------- +-- * View patterns + +-- | /O(n)/ Return the suffix of the second string if its prefix +-- matches the entire first string. +-- +-- Examples: +-- +-- > stripPrefix "foo" "foobar" == Just "bar" +-- > stripPrefix "" "baz" == Just "baz" +-- > stripPrefix "foo" "quux" == Nothing +-- +-- This is particularly useful with the @ViewPatterns@ extension to +-- GHC, as follows: +-- +-- > {-# LANGUAGE ViewPatterns #-} +-- > import Data.Text as T +-- > +-- > fnordLength :: JSString -> Int +-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf +-- > fnordLength _ = -1 +stripPrefix :: JSString -> JSString -> Maybe JSString +stripPrefix = coerce T.stripPrefix +{-# INLINE stripPrefix #-} + +-- | /O(n)/ Find the longest non-empty common prefix of two strings +-- and return it, along with the suffixes of each string at which they +-- no longer match. +-- +-- If the strings do not have a common prefix or either one is empty, +-- this function returns 'Nothing'. +-- +-- Examples: +-- +-- > commonPrefixes "foobar" "fooquux" == Just ("foo","bar","quux") +-- > commonPrefixes "veeble" "fetzer" == Nothing +-- > commonPrefixes "" "baz" == Nothing +commonPrefixes :: JSString -> JSString -> Maybe (JSString,JSString,JSString) +commonPrefixes = coerce T.commonPrefixes +{-# INLINE commonPrefixes #-} + +-- | /O(n)/ Return the prefix of the second string if its suffix +-- matches the entire first string. +-- +-- Examples: +-- +-- > stripSuffix "bar" "foobar" == Just "foo" +-- > stripSuffix "" "baz" == Just "baz" +-- > stripSuffix "foo" "quux" == Nothing +-- +-- This is particularly useful with the @ViewPatterns@ extension to +-- GHC, as follows: +-- +-- > {-# LANGUAGE ViewPatterns #-} +-- > import Data.Text as T +-- > +-- > quuxLength :: Text -> Int +-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre +-- > quuxLength _ = -1 +stripSuffix :: JSString -> JSString -> Maybe JSString +stripSuffix = coerce T.stripSuffix +{-# INLINE stripSuffix #-} + +---- | Add a list of non-negative numbers. Errors out on overflow. +--sumP :: String -> [Int] -> Int +--sumP fun = go 0 +-- where go !a (x:xs) +-- | ax >= 0 = go ax xs +-- | otherwise = overflowError fun +-- where ax = a + x +-- go a _ = a +-- +--emptyError :: String -> a +--emptyError fun = P.error $ "Data.JSString." ++ fun ++ ": empty input" +-- +--overflowError :: String -> a +--overflowError fun = P.error $ "Data.JSString." ++ fun ++ ": size overflow" +-- +--charWidth :: Int# -> Int# +--charWidth cp | isTrue# (cp >=# 0x10000#) = 2# +-- | otherwise = 1# +--{-# INLINE charWidth #-} diff --git a/src-ghc/Data/JSString/Internal.hs b/src-ghc/Data/JSString/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString/Internal.hs @@ -0,0 +1,1 @@ +module Data.JSString.Internal where diff --git a/src-ghc/Data/JSString/Internal/Fusion.hs b/src-ghc/Data/JSString/Internal/Fusion.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString/Internal/Fusion.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BangPatterns, MagicHash + #-} +module Data.JSString.Internal.Fusion ( -- * Types + Stream(..) + , Step(..) + + -- * Creation and elimination + , stream + , unstream + , reverseStream + + , length + + -- * Transformations + , reverse + + -- * Construction + -- ** Scans + , reverseScanr + + -- ** Accumulating maps + , mapAccumL + + -- ** Generation and unfolding + , unfoldrN + + -- * Indexing + , index + , findIndex + , countChar + ) where + +--import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#)) + +import Prelude hiding (length, reverse) +import qualified Data.Text.Internal.Fusion as T +--import Data.Char +import Data.Coerce (coerce) + +import Data.JSString.Internal.Type (JSString(..)) +--import qualified Data.JSString.Internal.Type as I +import Data.JSString.Internal.Fusion.Types +import qualified Data.JSString.Internal.Fusion.Common as S + +--import System.IO.Unsafe + +--import GHCJS.Prim + +default (Int) + +-- | /O(n)/ Convert a 'JSString' into a 'Stream Char'. +stream :: JSString -> Stream Char +stream = coerce T.stream +{-# INLINE [0] stream #-} + +-- | /O(n)/ Convert a 'JSString' into a 'Stream Char', but iterate +-- backwards. +reverseStream :: JSString -> Stream Char +reverseStream = coerce T.reverseStream +{-# INLINE [0] reverseStream #-} + +-- | /O(n)/ Convert a 'Stream Char' into a 'JSString'. +unstream :: Stream Char -> JSString +unstream = coerce T.unstream +{-# INLINE [0] unstream #-} +{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-} + + +-- ---------------------------------------------------------------------------- +-- * Basic stream functions + +--runJSString :: ((a -> IO a) -> IO a) -> a +--runJSString f = unsafePerformIO (f pure) + +length :: Stream Char -> Int +length = S.lengthI +{-# INLINE[0] length #-} + +-- | /O(n)/ Reverse the characters of a string. +reverse :: Stream Char -> JSString +reverse = coerce T.reverse +{-# INLINE [0] reverse #-} + +-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with +-- the input and result reversed. +reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char +reverseScanr = coerce T.reverseScanr +{-# INLINE reverseScanr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed +-- value. However, the length of the result is limited by the +-- first argument to 'unfoldrN'. This function is more efficient than +-- 'unfoldr' when the length of the result is known. +unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char +unfoldrN n = S.unfoldrNI n +{-# INLINE [0] unfoldrN #-} + +------------------------------------------------------------------------------- +-- ** Indexing streams + +-- | /O(n)/ stream index (subscript) operator, starting from 0. +index :: Stream Char -> Int -> Char +index = S.indexI +{-# INLINE [0] index #-} + +-- | The 'findIndex' function takes a predicate and a stream and +-- returns the index of the first element in the stream +-- satisfying the predicate. +findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int +findIndex = S.findIndexI +{-# INLINE [0] findIndex #-} + +-- | /O(n)/ The 'count' function returns the number of times the query +-- element appears in the given stream. +countChar :: Char -> Stream Char -> Int +countChar = S.countCharI +{-# INLINE [0] countChar #-} + +-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a +-- function to each element of a 'Text', passing an accumulating +-- parameter from left to right, and returns a final 'JSString'. +mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, JSString) +mapAccumL a b c = coerce (T.mapAccumL a b c) +{-# INLINE [0] mapAccumL #-} + +------------------------------------------------------------------------------- + diff --git a/src-ghc/Data/JSString/Internal/Fusion/CaseMapping.hs b/src-ghc/Data/JSString/Internal/Fusion/CaseMapping.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString/Internal/Fusion/CaseMapping.hs @@ -0,0 +1,570 @@ +{-# LANGUAGE Rank2Types #-} +-- AUTOMATICALLY GENERATED - DO NOT EDIT +-- Generated by scripts/SpecialCasing.hs +-- CaseFolding-6.3.0.txt +-- Date: 2012-12-20, 22:14:35 GMT [MD] +-- SpecialCasing-6.3.0.txt +-- Date: 2013-05-08, 13:54:51 GMT [MD] + +module Data.JSString.Internal.Fusion.CaseMapping where +import Data.Char +import Data.JSString.Internal.Fusion.Types + +upperMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE upperMapping #-} +-- LATIN SMALL LETTER SHARP S +upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000') +-- LATIN SMALL LIGATURE FF +upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000') +-- LATIN SMALL LIGATURE FI +upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000') +-- LATIN SMALL LIGATURE FL +upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000') +-- LATIN SMALL LIGATURE FFI +upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049') +-- LATIN SMALL LIGATURE FFL +upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c') +-- LATIN SMALL LIGATURE LONG S T +upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000') +-- LATIN SMALL LIGATURE ST +upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- LATIN SMALL LETTER J WITH CARON +upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399') +upperMapping c s = Yield (toUpper c) (CC s '\0' '\0') +lowerMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE lowerMapping #-} +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000') +lowerMapping c s = Yield (toLower c) (CC s '\0' '\0') +titleMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE titleMapping #-} +-- LATIN SMALL LETTER SHARP S +titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000') +-- LATIN SMALL LIGATURE FF +titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000') +-- LATIN SMALL LIGATURE FI +titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000') +-- LATIN SMALL LIGATURE FL +titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000') +-- LATIN SMALL LIGATURE FFI +titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069') +-- LATIN SMALL LIGATURE FFL +titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c') +-- LATIN SMALL LIGATURE LONG S T +titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000') +-- LATIN SMALL LIGATURE ST +titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- LATIN SMALL LETTER J WITH CARON +titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345') +titleMapping c s = Yield (toTitle c) (CC s '\0' '\0') +foldMapping :: forall s. Char -> s -> Step (CC s) Char +{-# INLINE foldMapping #-} +-- MICRO SIGN +foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER SHARP S +foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000') +-- LATIN CAPITAL LETTER I WITH DOT ABOVE +foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000') +-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE +foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000') +-- LATIN SMALL LETTER LONG S +foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER J WITH CARON +foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000') +-- COMBINING GREEK YPOGEGRAMMENI +foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER FINAL SIGMA +foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000') +-- GREEK BETA SYMBOL +foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000') +-- GREEK THETA SYMBOL +foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000') +-- GREEK PHI SYMBOL +foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000') +-- GREEK PI SYMBOL +foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000') +-- GREEK KAPPA SYMBOL +foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000') +-- GREEK RHO SYMBOL +foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000') +-- GREEK LUNATE EPSILON SYMBOL +foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000') +-- ARMENIAN SMALL LIGATURE ECH YIWN +foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000') +-- GEORGIAN CAPITAL LETTER YN +foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000') +-- GEORGIAN CAPITAL LETTER AEN +foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000') +-- LATIN SMALL LETTER H WITH LINE BELOW +foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000') +-- LATIN SMALL LETTER T WITH DIAERESIS +foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000') +-- LATIN SMALL LETTER W WITH RING ABOVE +foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER Y WITH RING ABOVE +foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000') +-- LATIN SMALL LETTER A WITH RIGHT HALF RING +foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000') +-- LATIN SMALL LETTER LONG S WITH DOT ABOVE +foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER SHARP S +foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI +foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA +foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA +foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301') +-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI +foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI +foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI +foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI +foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI +foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI +foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI +foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI +foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI +foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000') +-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI +foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI +foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI +foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI +foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000') +-- GREEK PROSGEGRAMMENI +foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000') +-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI +foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI +foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI +foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA +foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA +foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER IOTA WITH PERISPOMENI +foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA +foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA +foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301') +-- GREEK SMALL LETTER RHO WITH PSILI +foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI +foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI +foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342') +-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI +foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI +foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI +foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI +foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000') +-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI +foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9') +-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI +foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000') +-- COPTIC CAPITAL LETTER BOHAIRIC KHEI +foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER C WITH BAR +foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000') +-- LATIN CAPITAL LETTER H WITH HOOK +foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000') +-- LATIN SMALL LIGATURE FF +foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000') +-- LATIN SMALL LIGATURE FI +foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000') +-- LATIN SMALL LIGATURE FL +foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000') +-- LATIN SMALL LIGATURE FFI +foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069') +-- LATIN SMALL LIGATURE FFL +foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c') +-- LATIN SMALL LIGATURE LONG S T +foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000') +-- LATIN SMALL LIGATURE ST +foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN NOW +foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN ECH +foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN INI +foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000') +-- ARMENIAN SMALL LIGATURE VEW NOW +foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000') +-- ARMENIAN SMALL LIGATURE MEN XEH +foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000') +foldMapping c s = Yield (toLower c) (CC s '\0' '\0') diff --git a/src-ghc/Data/JSString/Internal/Fusion/Common.hs b/src-ghc/Data/JSString/Internal/Fusion/Common.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString/Internal/Fusion/Common.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE BangPatterns, MagicHash, RankNTypes #-} + +module Data.JSString.Internal.Fusion.Common ( -- * Creation and elimination + singleton + , streamList + , unstreamList + , streamCString# + + -- * Basic interface + , cons + , snoc + , append + , head + , uncons + , last + , tail + , init + , null + , lengthI + , compareLengthI + , isSingleton + + -- * Transformations + , map + , intercalate + , intersperse + + -- ** Case conversion + -- $case + , toCaseFold + , toLower + , toTitle + , toUpper + + -- ** Justification + , justifyLeftI + + -- * Folds + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , any + , all + , maximum + , minimum + + -- * Construction + -- ** Scans + , scanl + + -- ** Accumulating maps + -- , mapAccumL + + -- ** Generation and unfolding + , replicateCharI + , replicateI + , unfoldr + , unfoldrNI + + -- * Substrings + -- ** Breaking strings + , take + , drop + , takeWhile + , dropWhile + + -- * Predicates + , isPrefixOf + + -- * Searching + , elem + , filter + + -- * Indexing + , findBy + , indexI + , findIndexI + , countCharI + + -- * Zipping and unzipping + , zipWith + ) where + +import Data.Text.Internal.Fusion.Common +import Prelude () diff --git a/src-ghc/Data/JSString/Internal/Fusion/Types.hs b/src-ghc/Data/JSString/Internal/Fusion/Types.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString/Internal/Fusion/Types.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns, ExistentialQuantification #-} +-- | +-- Module : Data.Text.Internal.Fusion.Types +-- Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009, +-- (c) Jasper Van der Jeugt 2011 +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Core stream fusion functionality for text. + +module Data.JSString.Internal.Fusion.Types + ( + CC(..) +-- , M(..) +-- , M8 + , PairS(..) + , RS(..) + , Step(..) + , Stream(..) +-- , Switch(..) + , empty + ) where + +import Data.Text.Internal.Fusion.Types +-- import Data.Text.Internal.Fusion.Size +-- import Data.Word (Word8) + +---- | Specialised tuple for case conversion. +--data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char +-- +---- | Specialised, strict Maybe-like type. +--data M a = N +-- | J !a +-- +--type M8 = M Word8 +-- +---- Restreaming state. +--data RS s +-- = RS0 !s +-- | RS1 !s {-# UNPACK #-} !Word8 +-- | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 +-- | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 +-- +--infixl 2 :*: +--data PairS a b = !a :*: !b +-- -- deriving (Eq, Ord, Show) +-- +---- | Allow a function over a stream to switch between two states. +--data Switch = S1 | S2 +-- +--data Step s a = Done +-- | Skip !s +-- | Yield !a !s +-- +--{- +--instance (Show a) => Show (Step s a) +-- where show Done = "Done" +-- show (Skip _) = "Skip" +-- show (Yield x _) = "Yield " ++ show x +---} +-- +--instance (Eq a) => Eq (Stream a) where +-- (==) = eq +-- +--instance (Ord a) => Ord (Stream a) where +-- compare = cmp +-- +---- The length hint in a Stream has two roles. If its value is zero, +---- we trust it, and treat the stream as empty. Otherwise, we treat it +---- as a hint: it should usually be accurate, so we use it when +---- unstreaming to decide what size array to allocate. However, the +---- unstreaming functions must be able to cope with the hint being too +---- small or too large. +-- +--data Stream a = +-- forall s. Stream +-- (s -> Step s a) -- stepper function +-- !s -- current state +-- +---- | /O(n)/ Determines if two streams are equal. +--eq :: (Eq a) => Stream a -> Stream a -> Bool +--eq (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2) +-- where +-- loop Done Done = True +-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') +-- loop (Skip s1') x2 = loop (next1 s1') x2 +-- loop x1 (Skip s2') = loop x1 (next2 s2') +-- loop Done _ = False +-- loop _ Done = False +-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 && +-- loop (next1 s1') (next2 s2') +--{-# INLINE [0] eq #-} +-- +--cmp :: (Ord a) => Stream a -> Stream a -> Ordering +--cmp (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2) +-- where +-- loop Done Done = EQ +-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2') +-- loop (Skip s1') x2 = loop (next1 s1') x2 +-- loop x1 (Skip s2') = loop x1 (next2 s2') +-- loop Done _ = LT +-- loop _ Done = GT +-- loop (Yield x1 s1') (Yield x2 s2') = +-- case compare x1 x2 of +-- EQ -> loop (next1 s1') (next2 s2') +-- other -> other +--{-# INLINE [0] cmp #-} +-- +---- | The empty stream. +--empty :: Stream a +--empty = Stream next () +-- where next _ = Done +--{-# INLINE [0] empty #-} diff --git a/src-ghc/Data/JSString/Internal/Search.hs b/src-ghc/Data/JSString/Internal/Search.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString/Internal/Search.hs @@ -0,0 +1,11 @@ +module Data.JSString.Internal.Search ( indices + ) where + +import Data.Coerce (coerce) + +import Data.JSString.Internal.Type (JSString(..)) + +import qualified Data.Text.Internal.Search as T + +indices :: JSString -> JSString -> [Int] +indices = coerce T.indices diff --git a/src-ghc/Data/JSString/Internal/Type.hs b/src-ghc/Data/JSString/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString/Internal/Type.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DeriveDataTypeable, UnboxedTuples, MagicHash, + BangPatterns, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_HADDOCK not-home #-} +module Data.JSString.Internal.Type ( JSString(..) + , empty + , empty_ + , safe + , firstf + ) where + + {- + -- * Construction + , text + , textP + -- * Safety + , safe + -- * Code that must be here for accessibility + , empty + , empty_ + -- * Utilities + , firstf + -- * Checked multiplication + , mul + , mul32 + , mul64 + -- * Debugging + , showText + + ) where +-} +import Control.DeepSeq + +import Data.Coerce (coerce) +import Data.Text (Text) +import qualified Data.Text as T (empty) +import Data.String (IsString) +import Data.Aeson (ToJSON(..), FromJSON(..)) +import Data.Data (Data) +-- import Data.Text.Internal.Unsafe.Char (ord) +import Data.Typeable (Typeable) +import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#) + +-- | A wrapper around a JavaScript string +newtype JSString = JSString Text deriving(Show, Read, IsString, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable) + +instance NFData JSString where rnf !_ = () + +-- | /O(1)/ The empty 'JSString'. +empty :: JSString +empty = coerce T.empty +{-# INLINE [1] empty #-} + +-- | A non-inlined version of 'empty'. +empty_ :: JSString +empty_ = coerce T.empty +{-# NOINLINE empty_ #-} + +safe :: Char -> Char +safe c@(C# cc) + | isTrue# (andI# (ord# cc) 0x1ff800# /=# 0xd800#) = c + | otherwise = '\xfffd' +{-# INLINE [0] safe #-} + + +-- | Apply a function to the first element of an optional pair. +firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b) +firstf f (Just (a, b)) = Just (f a, b) +firstf _ Nothing = Nothing + +{- +-- | Checked multiplication. Calls 'error' if the result would +-- overflow. +mul :: Int -> Int -> Int +#if WORD_SIZE_IN_BITS == 64 +mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b +#else +mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b +#endif +{-# INLINE mul #-} +infixl 7 `mul` + +-- | Checked multiplication. Calls 'error' if the result would +-- overflow. +mul64 :: Int64 -> Int64 -> Int64 +mul64 a b + | a >= 0 && b >= 0 = mul64_ a b + | a >= 0 = -mul64_ a (-b) + | b >= 0 = -mul64_ (-a) b + | otherwise = mul64_ (-a) (-b) +{-# INLINE mul64 #-} +infixl 7 `mul64` + +mul64_ :: Int64 -> Int64 -> Int64 +mul64_ a b + | ahi > 0 && bhi > 0 = error "overflow" + | top > 0x7fffffff = error "overflow" + | total < 0 = error "overflow" + | otherwise = total + where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #) + (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #) + top = ahi * blo + alo * bhi + total = (top `shiftL` 32) + alo * blo +{-# INLINE mul64_ #-} + +-- | Checked multiplication. Calls 'error' if the result would +-- overflow. +mul32 :: Int32 -> Int32 -> Int32 +mul32 a b = case fromIntegral a * fromIntegral b of + ab | ab < min32 || ab > max32 -> error "overflow" + | otherwise -> fromIntegral ab + where min32 = -0x80000000 :: Int64 + max32 = 0x7fffffff +{-# INLINE mul32 #-} +infixl 7 `mul32` +-} diff --git a/src-ghc/Data/JSString/Text.hs b/src-ghc/Data/JSString/Text.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Data/JSString/Text.hs @@ -0,0 +1,52 @@ +{- | Conversion between 'Data.Text.Text' and 'Data.JSString.JSString' -} + +module Data.JSString.Text + ( textToJSString + , textFromJSString + , lazyTextToJSString + , lazyTextFromJSString + , textFromJSVal + , lazyTextFromJSVal + ) where + +import GHCJS.Prim.Internal (JSVal) + +import Data.Coerce (coerce) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Data.JSString.Internal.Type + +import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..)) +import Language.Javascript.JSaddle.Native.Internal + (valueToString) + +textToJSString :: T.Text -> JSString +textToJSString = coerce +{-# INLINE textToJSString #-} + +textFromJSString :: JSString -> T.Text +textFromJSString = coerce +{-# INLINE textFromJSString #-} + +lazyTextToJSString :: TL.Text -> JSString +lazyTextToJSString = coerce . TL.toStrict +{-# INLINE lazyTextToJSString #-} + +lazyTextFromJSString :: JSString -> TL.Text +lazyTextFromJSString = TL.fromStrict . coerce +{-# INLINE lazyTextFromJSString #-} + +-- | returns the empty Text if not a string +textFromJSVal :: JSVal -> GHCJSPure T.Text +textFromJSVal j = GHCJSPure $ textFromJSString <$> valToJSString j +{-# INLINE textFromJSVal #-} + +-- | returns the empty Text if not a string +lazyTextFromJSVal :: JSVal -> GHCJSPure TL.Text +lazyTextFromJSVal j = GHCJSPure $ lazyTextFromJSString <$> valToJSString j +{-# INLINE lazyTextFromJSVal #-} + +valToJSString :: JSVal -> JSM JSString +valToJSString = valueToString +{-# INLINE valToJSString #-} diff --git a/src-ghc/GHCJS/Buffer.hs b/src-ghc/GHCJS/Buffer.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Buffer.hs @@ -0,0 +1,117 @@ +module GHCJS.Buffer + ( Buffer + , MutableBuffer + , create + , createFromArrayBuffer + , thaw, freeze, clone + -- * JavaScript properties + , byteLength + , getArrayBuffer + , getUint8Array + , getUint16Array + , getInt32Array + , getDataView + , getFloat32Array + , getFloat64Array + -- * bytestring + , toByteString, fromByteString + ) where + +import GHCJS.Buffer.Types + +import Control.Lens.Operators ((^.)) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 (encode, decode) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) + +import qualified JavaScript.TypedArray.Internal.Types as I +import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..)) +import JavaScript.TypedArray.DataView.Internal (SomeDataView(..)) + +import GHCJS.Marshal (FromJSVal(..)) +import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..), ghcjsPure) +import Language.Javascript.JSaddle.Object (js, js2, jsg1, jsg3) + +create :: Int -> JSM MutableBuffer +create n | n >= 0 = SomeBuffer <$> jsg1 "h$newByteArray" n + | otherwise = error "create: negative size" +{-# INLINE create #-} + +createFromArrayBuffer :: SomeArrayBuffer any -> GHCJSPure (SomeBuffer any) +createFromArrayBuffer (SomeArrayBuffer buf) = GHCJSPure $ SomeBuffer <$> jsg1 "h$wrapBuffer" buf +{-# INLINE createFromArrayBuffer #-} + +getArrayBuffer :: SomeBuffer any -> GHCJSPure (SomeArrayBuffer any) +getArrayBuffer (SomeBuffer buf) = GHCJSPure $ SomeArrayBuffer <$> buf ^. js "buf" +{-# INLINE getArrayBuffer #-} + +getInt32Array :: SomeBuffer any -> GHCJSPure (I.SomeInt32Array any) +getInt32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "i3" +{-# INLINE getInt32Array #-} + +getUint8Array :: SomeBuffer any -> GHCJSPure (I.SomeUint8Array any) +getUint8Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u3" +{-# INLINE getUint8Array #-} + +getUint16Array :: SomeBuffer any -> GHCJSPure (I.SomeUint16Array any) +getUint16Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u1" +{-# INLINE getUint16Array #-} + +getFloat32Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat32Array any) +getFloat32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f3" +{-# INLINE getFloat32Array #-} + +getFloat64Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat64Array any) +getFloat64Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f6" +{-# INLINE getFloat64Array #-} + +getDataView :: SomeBuffer any -> GHCJSPure (SomeDataView any) +getDataView (SomeBuffer buf) = GHCJSPure $ SomeDataView <$> buf ^. js "dv" +{-# INLINE getDataView #-} + +freeze :: MutableBuffer -> JSM Buffer +freeze = js_clone +{-# INLINE freeze #-} + +thaw :: Buffer -> JSM MutableBuffer +thaw = js_clone +{-# INLINE thaw #-} + +clone :: MutableBuffer -> JSM (SomeBuffer any2) +clone = js_clone +{-# INLINE clone #-} + +fromByteString :: ByteString -> GHCJSPure (Buffer, Int, Int) +fromByteString bs = GHCJSPure $ do + buffer <- SomeBuffer <$> jsg1 "h$newByteArrayBase64String" (decodeUtf8 $ B64.encode bs) + return (buffer, 0, BS.length bs) +{-# INLINE fromByteString #-} + +-- | Wrap a 'Buffer' into a 'ByteString' using the given offset +-- and length. +toByteString :: Int -> Maybe Int -> Buffer -> GHCJSPure ByteString +toByteString off mbLen buf = GHCJSPure $ do + bufLen <- ghcjsPure $ byteLength buf + case mbLen of + _ | off < 0 -> error "toByteString: negative offset" + | off > bufLen -> error "toByteString: offset past end of buffer" + Just len | len < 0 -> error "toByteString: negative length" + | len > bufLen - off -> error "toByteString: length past end of buffer" + | otherwise -> ghcjsPure $ unsafeToByteString off len buf + Nothing -> ghcjsPure $ unsafeToByteString off (bufLen - off) buf + +unsafeToByteString :: Int -> Int -> Buffer -> GHCJSPure ByteString +unsafeToByteString off len (SomeBuffer buf) = GHCJSPure $ do + b64 <- jsg3 "h$byteArrayToBase64String" off len buf >>= fromJSValUnchecked + return $ case B64.decode (encodeUtf8 b64) of + Left err -> error $ "unsafeToByteString base 64 decode error :" ++ err + Right bs -> bs + +byteLength :: SomeBuffer any -> GHCJSPure Int +byteLength (SomeBuffer buf) = GHCJSPure $ buf ^. js "len" >>= fromJSValUnchecked +{-# INLINE byteLength #-} + +js_clone :: SomeBuffer any1 -> JSM (SomeBuffer any2) +js_clone (SomeBuffer buf) = SomeBuffer <$> jsg1 "h$wrapBuffer" (buf ^. js "buf" ^. js2 "slice" (buf ^. js "u8" ^. js "byteOffset") (buf ^. js "len")) diff --git a/src-ghc/GHCJS/Buffer/Types.hs b/src-ghc/GHCJS/Buffer/Types.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Buffer/Types.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-} + +module GHCJS.Buffer.Types where + +import GHCJS.Types +import GHCJS.Internal.Types + +newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer JSVal + +type Buffer = SomeBuffer Immutable +type MutableBuffer = SomeBuffer Mutable diff --git a/src-ghc/GHCJS/Foreign.hs b/src-ghc/GHCJS/Foreign.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Foreign.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Module : Language.Javascript.JSaddle.Value +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | +-- +----------------------------------------------------------------------------- +module GHCJS.Foreign ( + jsTrue + , jsFalse + , jsNull + , toJSBool +-- , fromJSBool + , jsUndefined + , isTruthy + , isNull + , isUndefined + , isObject + , isFunction + , isString + , isBoolean + , isSymbol + , isNumber + , JSType(..) + , jsTypeOf +) where + +import GHCJS.Foreign.Internal +import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..)) +import Language.Javascript.JSaddle.Object (jsg1) +import GHCJS.Marshal (FromJSVal(..)) + +isObject :: JSVal -> GHCJSPure Bool +isObject v = GHCJSPure $ jsg1 "h$isObject" v >>= fromJSValUnchecked +{-# INLINE isObject #-} + +isFunction :: JSVal -> GHCJSPure Bool +isFunction v = GHCJSPure $ jsg1 "h$isFunction" v >>= fromJSValUnchecked +{-# INLINE isFunction #-} + +isString :: JSVal -> GHCJSPure Bool +isString v = GHCJSPure $ jsg1 "h$isString" v >>= fromJSValUnchecked +{-# INLINE isString #-} + +isBoolean :: JSVal -> GHCJSPure Bool +isBoolean v = GHCJSPure $ jsg1 "h$isBoolean" v >>= fromJSValUnchecked +{-# INLINE isBoolean #-} + +isSymbol :: JSVal -> GHCJSPure Bool +isSymbol v = GHCJSPure $ jsg1 "h$isSymbol" v >>= fromJSValUnchecked +{-# INLINE isSymbol #-} + +isNumber :: JSVal -> GHCJSPure Bool +isNumber v = GHCJSPure $ jsg1 "h$isNumber" v >>= fromJSValUnchecked +{-# INLINE isNumber #-} + +jsTypeOf :: JSVal -> GHCJSPure JSType +jsTypeOf v = GHCJSPure $ toEnum <$> (jsg1 "h$jsonTypeOf" v >>= fromJSValUnchecked) +{-# INLINE jsTypeOf #-} diff --git a/src-ghc/GHCJS/Foreign/Internal.hs b/src-ghc/GHCJS/Foreign/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Foreign/Internal.hs @@ -0,0 +1,65 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.Javascript.JSaddle.Value +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | +-- +----------------------------------------------------------------------------- +module GHCJS.Foreign.Internal ( + jsTrue + , jsFalse + , jsNull + , toJSBool +-- , fromJSBool + , jsUndefined + , isTruthy + , isNull + , isUndefined + , JSType(..) +) where + +import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..)) +import Language.Javascript.JSaddle.Native.Internal + (valueToBool) +import Data.Typeable (Typeable) +import GHCJS.Prim (isNull, isUndefined) + +jsTrue :: JSVal +jsTrue = JSVal 3 +{-# INLINE jsTrue #-} + +jsFalse :: JSVal +jsFalse = JSVal 2 +{-# INLINE jsFalse #-} + +jsNull :: JSVal +jsNull = JSVal 0 +{-# INLINE jsNull #-} + +toJSBool :: Bool -> JSVal +toJSBool b = JSVal $ if b then 3 else 2 +{-# INLINE toJSBool #-} + +jsUndefined :: JSVal +jsUndefined = JSVal 1 +{-# INLINE jsUndefined #-} + +isTruthy :: JSVal -> GHCJSPure Bool +isTruthy = GHCJSPure . valueToBool +{-# INLINE isTruthy #-} + +-- types returned by JS typeof operator +data JSType = Undefined + | Object + | Boolean + | Number + | String + | Symbol + | Function + | Other -- ^ implementation dependent + deriving (Show, Eq, Ord, Enum, Typeable) + diff --git a/src-ghc/GHCJS/Internal/Types.hs b/src-ghc/GHCJS/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Internal/Types.hs @@ -0,0 +1,16 @@ +module GHCJS.Internal.Types ( IsJSVal(..) + , jsval + , MutabilityType(..) + , Mutable + , Immutable + , IsItMutable(..) + , Mutability + ) where + +import Language.Javascript.JSaddle.Types +import Language.Javascript.JSaddle.Native.Internal (stringToValue) + +instance IsJSVal JSString where + jsval_ a = GHCJSPure $ stringToValue a + {-# INLINE jsval_ #-} + diff --git a/src-ghc/GHCJS/Marshal.hs b/src-ghc/GHCJS/Marshal.hs --- a/src-ghc/GHCJS/Marshal.hs +++ b/src-ghc/GHCJS/Marshal.hs @@ -17,20 +17,24 @@ import qualified Data.Aeson as AE import Data.Int (Int8, Int16, Int32) +import Data.Text (Text) import Data.Word (Word8, Word16, Word32, Word) import GHC.Prim -import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), Command(ValueToJSONValue), Result(ValueToJSONValueResult)) -import Language.Javascript.JSaddle.Native (withToJSVal) -import Language.Javascript.JSaddle.Run(sendCommand) -import GHCJS.Marshal.Internal +import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), ghcjsPure) +import Language.Javascript.JSaddle.Native.Internal + (valueToJSONValue, jsonValueToValue, valueToNumber) + +import GHCJS.Types (JSString, isUndefined, isNull) +import GHCJS.Foreign.Internal (isTruthy) import GHCJS.Marshal.Pure () -import Language.Javascript.JSaddle.Value (isUndefinedIO, valToNumber, - valToBool, valMakeJSON) -import Language.Javascript.JSaddle.Array (fromListIO) -import qualified Language.Javascript.JSaddle.Array as A (read) +import JavaScript.Array (fromListIO) +import qualified JavaScript.Array as A (read) + +import GHCJS.Marshal.Internal + instance FromJSVal JSVal where fromJSValUnchecked x = return x {-# INLINE fromJSValUnchecked #-} @@ -42,65 +46,62 @@ fromJSVal = fromJSVal_pure -- {-# INLINE fromJSVal #-} instance FromJSVal Bool where - fromJSValUnchecked = valToBool + fromJSValUnchecked = ghcjsPure . isTruthy {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap Just . valToBool + fromJSVal = fmap Just . ghcjsPure . isTruthy {-# INLINE fromJSVal #-} instance FromJSVal Int where - fromJSValUnchecked = fmap round . valToNumber + fromJSValUnchecked = fmap round . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . round) . valToNumber + fromJSVal = fmap (Just . round) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Int8 where - fromJSValUnchecked = fmap round . valToNumber + fromJSValUnchecked = fmap round . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . round) . valToNumber + fromJSVal = fmap (Just . round) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Int16 where - fromJSValUnchecked = fmap round . valToNumber + fromJSValUnchecked = fmap round . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . round) . valToNumber + fromJSVal = fmap (Just . round) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Int32 where - fromJSValUnchecked = fmap round . valToNumber + fromJSValUnchecked = fmap round . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . round) . valToNumber + fromJSVal = fmap (Just . round) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Word where - fromJSValUnchecked = fmap round . valToNumber + fromJSValUnchecked = fmap round . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . round) . valToNumber + fromJSVal = fmap (Just . round) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Word8 where - fromJSValUnchecked = fmap round . valToNumber + fromJSValUnchecked = fmap round . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . round) . valToNumber + fromJSVal = fmap (Just . round) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Word16 where - fromJSValUnchecked = fmap round . valToNumber + fromJSValUnchecked = fmap round . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . round) . valToNumber + fromJSVal = fmap (Just . round) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Word32 where - fromJSValUnchecked = fmap round . valToNumber + fromJSValUnchecked = fmap round . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . round) . valToNumber + fromJSVal = fmap (Just . round) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Float where - fromJSValUnchecked = fmap realToFrac . valToNumber + fromJSValUnchecked = fmap realToFrac . valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap (Just . realToFrac) . valToNumber + fromJSVal = fmap (Just . realToFrac) . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal Double where - fromJSValUnchecked = valToNumber + fromJSValUnchecked = valueToNumber {-# INLINE fromJSValUnchecked #-} - fromJSVal = fmap Just . valToNumber + fromJSVal = fmap Just . valueToNumber {-# INLINE fromJSVal #-} instance FromJSVal AE.Value where - fromJSVal r = - withToJSVal r $ \rval -> do - ValueToJSONValueResult result <- sendCommand (ValueToJSONValue rval) - return $ Just result + fromJSVal r = Just <$> valueToJSONValue r {-# INLINE fromJSVal #-} instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1 @@ -127,7 +128,7 @@ jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a jf r n = MaybeT $ do r' <- A.read n (SomeJSArray r) - isUndefinedIO r >>= \case + ghcjsPure (isUndefined r) >>= \case True -> return Nothing False -> fromJSVal r' @@ -164,5 +165,5 @@ arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g] toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal -toJSVal_aeson = valMakeJSON . AE.toJSON +toJSVal_aeson = jsonValueToValue . AE.toJSON diff --git a/src-ghc/GHCJS/Marshal/Internal.hs b/src-ghc/GHCJS/Marshal/Internal.hs --- a/src-ghc/GHCJS/Marshal/Internal.hs +++ b/src-ghc/GHCJS/Marshal/Internal.hs @@ -3,19 +3,19 @@ LambdaCase #-} -module GHCJS.Marshal.Internal ( - FromJSVal(..) - , ToJSVal(..) - , PToJSVal(..) - , PFromJSVal(..) - , Purity(..) - , toJSVal_generic - , fromJSVal_generic - , toJSVal_pure - , fromJSVal_pure - , fromJSValUnchecked_pure - ) where +module GHCJS.Marshal.Internal ( FromJSVal(..) + , ToJSVal(..) + , PToJSVal(..) + , PFromJSVal(..) + , Purity(..) + , toJSVal_generic + , fromJSVal_generic + , toJSVal_pure + , fromJSVal_pure + , fromJSValUnchecked_pure + ) where +import Control.Applicative import Control.Monad import Data.Data @@ -25,12 +25,18 @@ import GHC.Generics -import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, JSString) -import Language.Javascript.JSaddle.Foreign (jsNull, jsTrue, isUndefinedIO) -import Language.Javascript.JSaddle.String (textToStr) +import qualified GHCJS.Prim.Internal as Prim +import qualified GHCJS.Foreign.Internal as F +import GHCJS.Types + +import qualified Data.JSString.Internal.Type as JSS + import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp) -import qualified JavaScript.Array.Internal as AI (create, push, read, fromListIO, toListIO) +import qualified JavaScript.Array.Internal as AI (SomeJSArray(..), create, push, read, fromListIO, toListIO) +import Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap) +import Language.Javascript.JSaddle.String (textToStr) + data Purity = PureShared -- ^ conversion is pure even if the original value is shared | PureExclusive -- ^ conversion is pure if the we only convert once deriving (Eq, Ord, Typeable, Data) @@ -49,6 +55,9 @@ toJSValListOf :: [a] -> JSM JSVal toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal + -- default toJSVal :: PToJSVal a => a -> JSM (JSVal a) + -- toJSVal x = return (pToJSVal x) + default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal toJSVal = toJSVal_generic id @@ -65,9 +74,15 @@ fromJSValUncheckedListOf :: JSVal -> JSM [a] fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce + -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a) + -- fromJSVal x = return (Just (pFromJSVal x)) + default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a) fromJSVal = fromJSVal_generic id + -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a + -- fromJSValUnchecked x = return (pFromJSVal x) + -- ----------------------------------------------------------------------------- class GToJSVal a where @@ -92,8 +107,8 @@ gToJSVal f _ (L1 x) = gToJSVal f True x gToJSVal f _ (R1 x) = gToJSVal f True x -instance (GToJSVal (a p)) => GToJSVal (M1 D c a p) where - gToJSVal f b (M1 x) = gToJSVal f b x +instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where + gToJSVal f b m@(M1 x) = gToJSVal f b x instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where gToJSVal f True m@(M1 x) = do @@ -109,7 +124,7 @@ gToJSProp f obj' xy return obj' gToJSVal f False xy = do - arr@(SomeJSArray arr') <- AI.create + arr@(AI.SomeJSArray arr') <- AI.create gToJSArr f arr xy return arr' @@ -133,10 +148,10 @@ AI.push r a instance GToJSVal (V1 p) where - gToJSVal _ _ _ = return jsNull + gToJSVal _ _ _ = return Prim.jsNull instance GToJSVal (U1 p) where - gToJSVal _ _ _ = return jsTrue + gToJSVal _ _ _ = return F.jsTrue toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ())) => (String -> String) -> a -> JSM JSVal @@ -163,26 +178,26 @@ gFromJSVal f b r = gFromJSVal f b r instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where - gFromJSVal f _b r = do + gFromJSVal f b r = do l <- gFromJSVal f True r case l of Just x -> return (L1 <$> Just x) Nothing -> fmap R1 <$> gFromJSVal f True r -instance GFromJSVal (a p) => GFromJSVal (M1 D c a p) where +instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where gFromJSVal f True r = do r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r) - isUndefinedIO r' >>= \case + ghcjsPure (isUndefined r') >>= \case True -> return Nothing False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r' gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where gFromJSVal f True r = gFromJSProp f r - gFromJSVal f False r = fmap fst <$> gFromJSArr f (SomeJSArray r) 0 + gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0 instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r @@ -197,7 +212,7 @@ instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where gFromJSProp f o = do p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o) - isUndefinedIO p >>= \case + ghcjsPure (isUndefined p) >>= \case True -> return Nothing False -> fmap M1 <$> gFromJSVal f False p @@ -214,7 +229,7 @@ instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where gFromJSArr f o n = do r <- AI.read n o - isUndefinedIO r >>= \case + ghcjsPure (isUndefined r) >>= \case True -> return Nothing False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r @@ -231,15 +246,15 @@ -- ----------------------------------------------------------------------------- fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a) -fromJSVal_pure x = return (Just (pFromJSVal x)) +fromJSVal_pure = return . Just . pFromJSVal {-# INLINE fromJSVal_pure #-} fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a -fromJSValUnchecked_pure x = return (pFromJSVal x) +fromJSValUnchecked_pure = return . pFromJSVal {-# INLINE fromJSValUnchecked_pure #-} toJSVal_pure :: PToJSVal a => a -> JSM JSVal -toJSVal_pure x = return (pToJSVal x) +toJSVal_pure = return . pToJSVal {-# INLINE toJSVal_pure #-} -- ----------------------------------------------------------------------------- diff --git a/src-ghc/GHCJS/Marshal/Pure.hs b/src-ghc/GHCJS/Marshal/Pure.hs --- a/src-ghc/GHCJS/Marshal/Pure.hs +++ b/src-ghc/GHCJS/Marshal/Pure.hs @@ -1,12 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module GHCJS.Marshal.Pure - ( PFromJSVal(..) - , PToJSVal(..) - ) where +module GHCJS.Marshal.Pure ( PFromJSVal(..) + , PToJSVal(..) + ) where +import GHCJS.Types +import GHCJS.Foreign.Internal (jsFalse, jsTrue) import GHCJS.Marshal.Internal -import Language.Javascript.JSaddle.Types (JSVal(..)) -import Language.Javascript.JSaddle.Foreign (jsFalse, jsTrue) instance PFromJSVal JSVal where pFromJSVal = id {-# INLINE pFromJSVal #-} diff --git a/src-ghc/GHCJS/Prim.hs b/src-ghc/GHCJS/Prim.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Prim.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHCJS.Prim ( module GHCJS.Prim.Internal + , fromJSString + , toJSString + , isNull + , isUndefined + ) where + +import GHCJS.Prim.Internal +--import Data.Int (Int64) +--import Data.Typeable (Typeable) +--import Unsafe.Coerce (unsafeCoerce) + +--import Data.Aeson (ToJSON(..), FromJSON(..)) +import qualified Data.Text as T (unpack, pack) +import Data.JSString.Text (textFromJSVal) + +--import GHC.Prim +--import qualified GHC.Exception as Ex +--import qualified GHC.Exts as Exts + +import Language.Javascript.JSaddle.Types (JSVal(..), JSString(..), GHCJSPure(..), ghcjsPureMap) +import qualified Language.Javascript.JSaddle.Native.Internal as N + (stringToValue, isNull, isUndefined) +{- | Low-level conversion utilities for packages that cannot + depend on ghcjs-base + -} + +fromJSString :: JSVal -> GHCJSPure String +fromJSString = ghcjsPureMap T.unpack . textFromJSVal +{-# INLINE fromJSString #-} + +toJSString :: String -> GHCJSPure JSVal +toJSString s = GHCJSPure $ N.stringToValue (JSString $ T.pack s) +{-# INLINE toJSString #-} + +--fromJSArray :: JSVal -> IO [JSVal] +--fromJSArray = unsafeCoerce . js_fromJSArray +--{-# INLINE fromJSArray #-} +-- +--toJSArray :: [JSVal] -> IO JSVal +--toJSArray = js_toJSArray . unsafeCoerce . seqList +--{-# INLINE toJSArray #-} +-- +--{- | returns zero if the JSVal does not contain a number +-- -} +--fromJSInt :: JSVal -> Int +--fromJSInt = js_fromJSInt +--{-# INLINE fromJSInt #-} +-- +--toJSInt :: Int -> JSVal +--toJSInt = js_toJSInt +--{-# INLINE toJSInt #-} +-- + +isNull :: JSVal -> GHCJSPure Bool +isNull = GHCJSPure . N.isNull +{-# INLINE isNull #-} + +isUndefined :: JSVal -> GHCJSPure Bool +isUndefined = GHCJSPure . N.isUndefined +{-# INLINE isUndefined #-} + +--getProp :: JSVal -> String -> IO JSVal +--getProp o p = js_getProp o (unsafeCoerce $ seqList p) +--{-# INLINE getProp #-} +-- +--getProp' :: JSVal -> JSVal -> IO JSVal +--getProp' o p = js_getProp' o p +--{-# INLINE getProp' #-} +-- +---- reduce the spine and all list elements to whnf +--seqList :: [a] -> [a] +--seqList xs = go xs `seq` xs +-- where go (x:xs) = x `seq` go xs +-- go [] = () +-- +--seqListSpine :: [a] -> [a] +--seqListSpine xs = go xs `seq` xs +-- where go (x:xs) = go xs +-- go [] = () diff --git a/src-ghc/GHCJS/Prim/Internal.hs b/src-ghc/GHCJS/Prim/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Prim/Internal.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHCJS.Prim.Internal ( JSVal(..) + , JSValueRef + , JSException(..) + , WouldBlockException(..) + , mkJSException + , jsNull + ) where + +import Control.DeepSeq (NFData(..)) +import Data.Int (Int64) +import Data.Typeable (Typeable) +import Unsafe.Coerce (unsafeCoerce) + +import Data.Aeson (ToJSON(..), FromJSON(..)) + +import qualified GHC.Exception as Ex + +-- A reference to a particular JavaScript value inside the JavaScript context +type JSValueRef = Int64 + +{- + JSVal is a boxed type that can be used as FFI + argument or result. +-} +newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON) + +instance NFData JSVal where + rnf x = x `seq` () + + +{- + When a JavaScript exception is raised inside + a safe or interruptible foreign call, it is converted + to a JSException + -} +data JSException = JSException JSVal String + deriving (Typeable) + +instance Ex.Exception JSException + +instance Show JSException where + show (JSException _ xs) = "JavaScript exception: " ++ xs + +mkJSException :: JSVal -> IO JSException +mkJSException ref = + return (JSException (unsafeCoerce ref) "") + +jsNull :: JSVal +jsNull = JSVal 0 +{-# INLINE jsNull #-} + +{- | If a synchronous thread tries to do something that can only + be done asynchronously, and the thread is set up to not + continue asynchronously, it receives this exception. + -} +data WouldBlockException = WouldBlockException + deriving (Typeable) + +instance Show WouldBlockException where + show _ = "thread would block" + +instance Ex.Exception WouldBlockException + diff --git a/src-ghc/GHCJS/Types.hs b/src-ghc/GHCJS/Types.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Types.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} + +module GHCJS.Types ( JSVal + , WouldBlockException(..) + , JSException(..) + , IsJSVal + , jsval + , isNull + , isUndefined + , nullRef + , JSString + , mkRef + , Ref# +-- , toPtr +-- , fromPtr + , JSRef + ) where + +import Data.JSString.Internal.Type (JSString) +import GHCJS.Internal.Types + +import GHCJS.Prim + +import GHC.Int +import GHC.Types +import GHC.Prim +import GHC.Ptr + +import Control.DeepSeq +import Unsafe.Coerce + +type Ref# = Int64 + +mkRef :: Ref# -> JSVal +mkRef = JSVal +{-# INLINE mkRef #-} + +nullRef :: JSVal +nullRef = JSVal 0 +{-# INLINE nullRef #-} + +--toPtr :: JSVal -> Ptr a +--toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#) +--{-# INLINE toPtr #-} +-- +--fromPtr :: Ptr a -> JSVal +--fromPtr p = js_ptrVal p +--{-# INLINE fromPtr #-} +-- +--data Ptr' a = Ptr' ByteArray# Int# + +-- | This is a deprecated copmatibility wrapper for the old JSRef type. +-- +-- See https://github.com/ghcjs/ghcjs/issues/421 +type JSRef a = JSVal +{-# DEPRECATED JSRef "Use JSVal instead, or a more specific newtype wrapper of JSVal " #-} diff --git a/src-ghc/JavaScript/Array.hs b/src-ghc/JavaScript/Array.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/Array.hs @@ -0,0 +1,134 @@ +----------------------------------------------------------------------------- +-- +-- Module : JavaScript.Array +-- Copyright : (c) Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- +-- | Interface to JavaScript array +-- +----------------------------------------------------------------------------- +module JavaScript.Array + ( SomeJSArray(..) + , JSArray + , MutableJSArray + , create + , length + , lengthIO + , null + , fromList + , fromListIO + , toList + , toListIO + , index, (!) + , read + , write + , append + , push + , pop + , unshift + , shift + , reverse + , take + , takeIO + , drop + , dropIO + , slice + , sliceIO + , freeze + , unsafeFreeze + , thaw + , unsafeThaw + ) where + +import Prelude hiding (length, drop, read, take, reverse, null) +import Control.Monad (void) +import Language.Javascript.JSaddle.Types + (JSM, JSVal, SomeJSArray(..), JSArray, + MutableJSArray, GHCJSPure(..)) +import Control.Lens.Operators ((^.)) +import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js) +import Language.Javascript.JSaddle.Value (valToNumber) +import JavaScript.Array.Internal (create, fromList, fromListIO, toList, toListIO, index, read, push) + +length :: SomeJSArray m -> GHCJSPure Int +length = GHCJSPure . lengthIO +{-# INLINE length #-} + +lengthIO :: SomeJSArray m -> JSM Int +lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber) +{-# INLINE lengthIO #-} + +null :: SomeJSArray m -> GHCJSPure Bool +null = GHCJSPure . fmap (== 0) . lengthIO +{-# INLINE null #-} + +append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1) +append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y +{-# INLINE append #-} + +write :: Int -> JSVal -> MutableJSArray -> JSM () +write n e (SomeJSArray x) = void $ (x ## n) e +{-# INLINE write #-} + +pop :: MutableJSArray -> JSM JSVal +pop (SomeJSArray x) = x ^. js0 "pop" +{-# INLINE pop #-} + +unshift :: JSVal -> MutableJSArray -> JSM () +unshift e (SomeJSArray x) = void $ x ^. js1 "unshift" e +{-# INLINE unshift #-} + +shift :: MutableJSArray -> JSM JSVal +shift (SomeJSArray x) = x ^. js0 "shift" +{-# INLINE shift #-} + +reverse :: MutableJSArray -> JSM () +reverse (SomeJSArray x) = void $ x ^. js0 "reverse" +{-# INLINE reverse #-} + +take :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1) +take n = GHCJSPure . takeIO n +{-# INLINE take #-} + +takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1) +takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n +{-# INLINE takeIO #-} + +drop :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1) +drop n = GHCJSPure . dropIO n +{-# INLINE drop #-} + +dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1) +dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n +{-# INLINE dropIO #-} + +slice :: Int -> Int -> JSArray -> GHCJSPure (SomeJSArray m1) +slice s n = GHCJSPure . sliceIO s n +{-# INLINE slice #-} + +sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1) +sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n +{-# INLINE sliceIO #-} + +freeze :: MutableJSArray -> JSM JSArray +freeze (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice" (0::Int) +{-# INLINE freeze #-} + +unsafeFreeze :: MutableJSArray -> JSM JSArray +unsafeFreeze (SomeJSArray x) = pure (SomeJSArray x) +{-# INLINE unsafeFreeze #-} + +thaw :: JSArray -> JSM MutableJSArray +thaw (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice" (0::Int) +{-# INLINE thaw #-} + +unsafeThaw :: JSArray -> JSM MutableJSArray +unsafeThaw (SomeJSArray x) = pure (SomeJSArray x) +{-# INLINE unsafeThaw #-} + +(!) :: JSArray -> Int -> GHCJSPure JSVal +x ! n = GHCJSPure $ read n x +{-# INLINE (!) #-} + diff --git a/src-ghc/JavaScript/Array/Internal.hs b/src-ghc/JavaScript/Array/Internal.hs --- a/src-ghc/JavaScript/Array/Internal.hs +++ b/src-ghc/JavaScript/Array/Internal.hs @@ -1,46 +1,61 @@ {-# LANGUAGE OverloadedStrings #-} module JavaScript.Array.Internal - ( create + ( SomeJSArray(..) + , JSArray + , MutableJSArray + , STJSArray + , create + , fromList , fromListIO + , toList , toListIO + , index , read , push ) where import Prelude hiding(read) import Control.Monad (void) -import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, Object(..), JSString(..)) +import GHCJS.Types (JSVal) +import Data.JSString.Internal.Type (JSString(..)) +import Language.Javascript.JSaddle.Types (JSM, SomeJSArray(..), JSArray, MutableJSArray, STJSArray, Object(..), GHCJSPure(..)) import Language.Javascript.JSaddle.Native.Internal - (withObject, withJSVal, withJSString, withJSVals) + (newArray, getPropertyByName, getPropertyAtIndex, callAsFunction, valueToNumber) import Language.Javascript.JSaddle.Run (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand) create :: JSM MutableJSArray -create = SomeJSArray <$> sendLazyCommand (NewArray []) +create = SomeJSArray <$> newArray [] {-# INLINE create #-} +fromList :: [JSVal] -> GHCJSPure (SomeJSArray m) +fromList = GHCJSPure . fromListIO +{-# INLINE fromList #-} + fromListIO :: [JSVal] -> JSM (SomeJSArray m) -fromListIO xs = withJSVals xs $ \xs' -> SomeJSArray <$> sendLazyCommand (NewArray xs') +fromListIO xs = SomeJSArray <$> newArray xs {-# INLINE fromListIO #-} +toList :: SomeJSArray m -> GHCJSPure [JSVal] +toList = GHCJSPure . toListIO +{-# INLINE toList #-} + toListIO :: SomeJSArray m -> JSM [JSVal] -toListIO (SomeJSArray x) = - withObject (Object x) $ \this -> do - l <- withJSString (JSString "length") $ sendLazyCommand . GetPropertyByName this - withJSVal l $ \l' -> do - ValueToNumberResult len <- sendCommand (ValueToNumber l') - mapM (sendLazyCommand . GetPropertyAtIndex this) [0..round len - 1] +toListIO (SomeJSArray x) = do + len <- getPropertyByName (JSString "length") (Object x) >>= valueToNumber + mapM (`getPropertyAtIndex` Object x) [0..round len - 1] {-# INLINE toListIO #-} +index :: Int -> SomeJSArray m -> GHCJSPure JSVal +index n = GHCJSPure . read n +{-# INLINE index #-} + read :: Int -> SomeJSArray m -> JSM JSVal -read n (SomeJSArray x) = - withObject (Object x) $ \this -> sendLazyCommand $ GetPropertyAtIndex this n +read n (SomeJSArray x) = getPropertyAtIndex n $ Object x {-# INLINE read #-} push :: JSVal -> MutableJSArray -> JSM () -push e (SomeJSArray x) = - void $ withJSVal e $ \e' -> - withObject (Object x) $ \this -> do - f <- withJSString (JSString "push") $ sendLazyCommand . GetPropertyByName this - withObject (Object f) $ \f' -> sendLazyCommand $ CallAsFunction f' this [e'] +push e (SomeJSArray x) = void $ do + f <- getPropertyByName (JSString "push") (Object x) + void $ callAsFunction (Object f) (Object x) [e] {-# INLINE push #-} diff --git a/src-ghc/JavaScript/Object.hs b/src-ghc/JavaScript/Object.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/Object.hs @@ -0,0 +1,10 @@ +module JavaScript.Object ( Object + , create + , getProp, unsafeGetProp + , setProp, unsafeSetProp + -- , allProps + , listProps + -- , isInstanceOf + ) where + +import JavaScript.Object.Internal diff --git a/src-ghc/JavaScript/Object/Internal.hs b/src-ghc/JavaScript/Object/Internal.hs --- a/src-ghc/JavaScript/Object/Internal.hs +++ b/src-ghc/JavaScript/Object/Internal.hs @@ -7,43 +7,47 @@ , unsafeGetProp , setProp , unsafeSetProp --- , isInstanceOfIO +-- , isInstanceOf ) where import Language.Javascript.JSaddle.Types (JSM, JSVal, Object(..), JSString) import Language.Javascript.JSaddle.Native.Internal - (withObject, withJSString, withJSVal, wrapJSString) -import Language.Javascript.JSaddle.Run - (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand, sendAsyncCommand) + (newEmptyObject, propertyNames, getPropertyByName, setPropertyByName) +-- | create an empty object create :: JSM Object -create = Object <$> sendLazyCommand NewEmptyObject +create = newEmptyObject +{-# INLINE create #-} +--allProps :: Object -> JSM JSArray +--allProps o = js_allProps o +--{-# INLINE allProps #-} + listProps :: Object -> JSM [JSString] -listProps this = - withObject this $ \rthis -> do - PropertyNamesResult result <- sendCommand $ PropertyNames rthis - mapM wrapJSString result +listProps = propertyNames {-# INLINE listProps #-} -unsafeGetProp :: JSString -> Object -> JSM JSVal -unsafeGetProp name this = - withObject this $ \rthis -> - withJSString name $ sendLazyCommand . GetPropertyByName rthis -{-# INLINE unsafeGetProp #-} - +{- | get a property from an object. If accessing the property results in + an exception, the exception is converted to a JSException. Since exception + handling code prevents some optimizations in some JS engines, you may want + to use unsafeGetProp instead + -} getProp :: JSString -> Object -> JSM JSVal getProp = unsafeGetProp {-# INLINE getProp #-} -unsafeSetProp :: JSString -> JSVal -> Object -> JSM () -unsafeSetProp name val this = - withObject this $ \rthis -> - withJSString name $ \rname -> - withJSVal val $ \rval -> - sendAsyncCommand $ SetPropertyByName rthis rname rval -{-# INLINE unsafeSetProp #-} +unsafeGetProp :: JSString -> Object -> JSM JSVal +unsafeGetProp = getPropertyByName +{-# INLINE unsafeGetProp #-} setProp :: JSString -> JSVal -> Object -> JSM () setProp = unsafeSetProp {-# INLINE setProp #-} + +unsafeSetProp :: JSString -> JSVal -> Object -> JSM () +unsafeSetProp = setPropertyByName +{-# INLINE unsafeSetProp #-} + +--isInstanceOf :: Object -> JSVal -> GHCJSPure Bool +--isInstanceOf o s = js_isInstanceOf o s +--{-# INLINE isInstanceOf #-} diff --git a/src-ghc/JavaScript/TypedArray.hs b/src-ghc/JavaScript/TypedArray.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/TypedArray.hs @@ -0,0 +1,19 @@ +module JavaScript.TypedArray + ( TypedArray(..) + , Int8Array, Int16Array, Int32Array + , Uint8Array, Uint16Array, Uint32Array + , Uint8ClampedArray, Float32Array, Float64Array + , length + , byteLength + , byteOffset + , buffer + , subarray + , set + , unsafeSet + ) where + +import Prelude () + +import JavaScript.TypedArray.Internal +import JavaScript.TypedArray.Internal.Types + diff --git a/src-ghc/JavaScript/TypedArray/ArrayBuffer.hs b/src-ghc/JavaScript/TypedArray/ArrayBuffer.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/TypedArray/ArrayBuffer.hs @@ -0,0 +1,51 @@ +module JavaScript.TypedArray.ArrayBuffer + ( ArrayBuffer + , MutableArrayBuffer + , freeze, unsafeFreeze + , thaw, unsafeThaw + , byteLengthIO + ) where + +import Control.Lens.Operators ((^.)) + +import GHCJS.Marshal (fromJSValUnchecked) + +import Language.Javascript.JSaddle.Types (JSM) +import Language.Javascript.JSaddle.Object (jsg, new, js, js1, js2) +import JavaScript.TypedArray.ArrayBuffer.Internal + +create :: Int -> JSM MutableArrayBuffer +create n = SomeArrayBuffer <$> new (jsg "ArrayBuffer") [n] +{-# INLINE create #-} + +{- | Create an immutable 'ArrayBuffer' by copying a 'MutableArrayBuffer' -} +freeze :: MutableArrayBuffer -> JSM ArrayBuffer +freeze (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int) +{-# INLINE freeze #-} + +{- | Create an immutable 'ArrayBuffer' from a 'MutableArrayBuffer' without + copying. The result shares the buffer with the argument, not modify + the data in the 'MutableArrayBuffer' after freezing + -} +unsafeFreeze :: MutableArrayBuffer -> JSM ArrayBuffer +unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b) +{-# INLINE unsafeFreeze #-} + +{- | Create a 'MutableArrayBuffer' by copying an immutable 'ArrayBuffer' -} +thaw :: ArrayBuffer -> JSM MutableArrayBuffer +thaw (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int) +{-# INLINE thaw #-} + +unsafeThaw :: ArrayBuffer -> JSM MutableArrayBuffer +unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b) +{-# INLINE unsafeThaw #-} + +sliceIO :: Int -> Maybe Int -> SomeArrayBuffer any -> JSM (SomeArrayBuffer any) +sliceIO begin (Just end) (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js2 "slice" begin end +sliceIO begin _ (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" begin +{-# INLINE sliceIO #-} + +byteLengthIO :: SomeArrayBuffer any -> JSM Int +byteLengthIO (SomeArrayBuffer b) = b ^. js "byteLength" >>= fromJSValUnchecked +{-# INLINE byteLengthIO #-} + diff --git a/src-ghc/JavaScript/TypedArray/ArrayBuffer/Internal.hs b/src-ghc/JavaScript/TypedArray/ArrayBuffer/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/TypedArray/ArrayBuffer/Internal.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module JavaScript.TypedArray.ArrayBuffer.Internal where + +import GHCJS.Types + +import GHCJS.Internal.Types +import GHCJS.Marshal.Pure + +import GHC.Exts (State#) + +import Data.Typeable + +newtype SomeArrayBuffer (a :: MutabilityType s) = + SomeArrayBuffer JSVal deriving Typeable +instance IsJSVal (SomeArrayBuffer m) + +type ArrayBuffer = SomeArrayBuffer Immutable +type MutableArrayBuffer = SomeArrayBuffer Mutable +type STArrayBuffer s = SomeArrayBuffer (STMutable s) + +instance PToJSVal MutableArrayBuffer where + pToJSVal (SomeArrayBuffer b) = b +instance PFromJSVal MutableArrayBuffer where + pFromJSVal = SomeArrayBuffer diff --git a/src-ghc/JavaScript/TypedArray/ArrayBuffer/Type.hs b/src-ghc/JavaScript/TypedArray/ArrayBuffer/Type.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/TypedArray/ArrayBuffer/Type.hs @@ -0,0 +1,6 @@ +module JavaScript.TypedArray.ArrayBuffer.Type where + +import GHCJS.Prim + + + diff --git a/src-ghc/JavaScript/TypedArray/DataView/Internal.hs b/src-ghc/JavaScript/TypedArray/DataView/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/TypedArray/DataView/Internal.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} + +module JavaScript.TypedArray.DataView.Internal where + +import Data.Int +import Data.Typeable +import Data.Word + +import GHC.Exts ( State# ) + +import GHCJS.Prim +import GHCJS.Internal.Types + +import JavaScript.TypedArray.ArrayBuffer.Internal + +newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSVal + deriving Typeable + +type DataView = SomeDataView Immutable +type MutableDataView = SomeDataView Mutable +type STDataView s = SomeDataView (STMutable s) + +-- #define JSU foreign import javascript unsafe +-- #define JSS foreign import javascript safe +-- +--JSU "new DataView($1)" +-- js_dataView1 :: JSVal -> JSVal +--JSS "new DataView($2,$1)" +-- js_dataView2 :: Int -> JSVal -> SomeDataView m +--JSU "new DataView($2,$1)" +-- js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m +--JSS "new DataView($3,$1,$2)" +-- js_dataView :: Int -> Int -> JSVal -> SomeDataView m +--JSU "new DataView($3,$1,$2)" +-- js_unsafeDataView :: Int -> Int -> JSVal -> JSVal +--JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))" +-- js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1) +-- +---- ---------------------------------------------------------------------------- +---- immutable getters +-- +--JSU "$2.getInt8($1)" js_i_unsafeGetInt8 :: Int -> DataView -> Int8 +--JSU "$2.getUint8($1)" js_i_unsafeGetUint8 :: Int -> DataView -> Word8 +--JSU "$2.getInt16($1)" js_i_unsafeGetInt16BE :: Int -> DataView -> Int16 +--JSU "$2.getInt32($1)" js_i_unsafeGetInt32BE :: Int -> DataView -> Int +--JSU "$2.getUint16($1)" js_i_unsafeGetUint16BE :: Int -> DataView -> Word16 +--JSU "$2.getUint32($1)|0" js_i_unsafeGetUint32BE :: Int -> DataView -> Word +--JSU "$2.getFloat32($1)" js_i_unsafeGetFloat32BE :: Int -> DataView -> Double +--JSU "$2.getFloat64($1)" js_i_unsafeGetFloat64BE :: Int -> DataView -> Double +--JSU "$2.getInt16($1,true)" js_i_unsafeGetInt16LE :: Int -> DataView -> Int16 +--JSU "$2.getInt32($1,true)" js_i_unsafeGetInt32LE :: Int -> DataView -> Int +--JSU "$2.getUint16($1,true)" js_i_unsafeGetUint16LE :: Int -> DataView -> Word16 +--JSU "$2.getUint32($1,true)|0" js_i_unsafeGetUint32LE :: Int -> DataView -> Word +--JSU "$2.getFloat32($1,true)" js_i_unsafeGetFloat32LE :: Int -> DataView -> Double +--JSU "$2.getFloat64($1,true)" js_i_unsafeGetFloat64LE :: Int -> DataView -> Double +-- +--JSS "$2.getInt8($1)" js_i_getInt8 :: Int -> DataView -> Int8 +--JSS "$2.getUint8($1)" js_i_getUint8 :: Int -> DataView -> Word8 +--JSS "$2.getInt16($1)" js_i_getInt16BE :: Int -> DataView -> Int16 +--JSS "$2.getInt32($1)" js_i_getInt32BE :: Int -> DataView -> Int +--JSS "$2.getUint16($1)" js_i_getUint16BE :: Int -> DataView -> Word16 +--JSS "$2.getUint32($1)|0" js_i_getUint32BE :: Int -> DataView -> Word +--JSS "$2.getFloat32($1)" js_i_getFloat32BE :: Int -> DataView -> Double +--JSS "$2.getFloat64($1)" js_i_getFloat64BE :: Int -> DataView -> Double +--JSS "$2.getInt16($1,true)" js_i_getInt16LE :: Int -> DataView -> Int16 +--JSS "$2.getInt32($1,true)" js_i_getInt32LE :: Int -> DataView -> Int +--JSS "$2.getUint16($1,true)" js_i_getUint16LE :: Int -> DataView -> Word16 +--JSS "$2.getUint32($1,true)|0" js_i_getUint32LE :: Int -> DataView -> Word +--JSS "$2.getFloat32($1,true)" js_i_getFloat32LE :: Int -> DataView -> Double +--JSS "$2.getFloat64($1,true)" js_i_getFloat64LE :: Int -> DataView -> Double +-- +---- ---------------------------------------------------------------------------- +---- mutable getters +-- +--JSU "$2.getInt8($1)" js_m_unsafeGetInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #) +--JSU "$2.getUint8($1)" js_m_unsafeGetUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #) +--JSU "$2.getInt16($1)" js_m_unsafeGetInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) +--JSU "$2.getInt32($1)" js_m_unsafeGetInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) +--JSU "$2.getUint16($1)" js_m_unsafeGetUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) +--JSU "$2.getUint32($1)|0" js_m_unsafeGetUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) +--JSU "$2.getFloat32($1)" js_m_unsafeGetFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +--JSU "$2.getFloat64($1)" js_m_unsafeGetFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +--JSU "$2.getInt16($1,true)" js_m_unsafeGetInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) +--JSU "$2.getInt32($1,true)" js_m_unsafeGetInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) +--JSU "$2.getUint16($1,true)" js_m_unsafeGetUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) +--JSU "$2.getUint32($1,true)|0" js_m_unsafeGetUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) +--JSU "$2.getFloat32($1,true)" js_m_unsafeGetFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +--JSU "$2.getFloat64($1,true)" js_m_unsafeGetFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +-- +--JSS "$2.getInt8($1)" js_m_getInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #) +--JSS "$2.getUint8($1)" js_m_getUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #) +--JSS "$2.getInt16($1)" js_m_getInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) +--JSS "$2.getInt32($1)" js_m_getInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) +--JSS "$2.getUint16($1)" js_m_getUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) +--JSS "$2.getUint32($1)|0" js_m_getUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) +--JSS "$2.getFloat32($1)" js_m_getFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +--JSS "$2.getFloat64($1)" js_m_getFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +--JSS "$2.getInt16($1,true)" js_m_getInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) +--JSS "$2.getInt32($1,true)" js_m_getInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) +--JSS "$2.getUint16($1,true)" js_m_getUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) +--JSS "$2.getUint32($1,true)|0" js_m_getUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) +--JSS "$2.getFloat32($1,true)" js_m_getFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +--JSS "$2.getFloat64($1,true)" js_m_getFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +-- +---- ---------------------------------------------------------------------------- +---- mutable setters +-- +--JSU "$3.setInt8($1,$2)" js_unsafeSetInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setUint8($1,$2)" js_unsafeSetUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setInt16($1,$2)" js_unsafeSetInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setInt32($1,$2)" js_unsafeSetInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setUint16($1,$2)" js_unsafeSetUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setUint32($1,$2)" js_unsafeSetUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setFloat32($1,$2)" js_unsafeSetFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setFloat64($1,$2)" js_unsafeSetFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setInt16($1,$2,true)" js_unsafeSetInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setInt32($1,$2,true)" js_unsafeSetInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setUint16($1,$2,true)" js_unsafeSetUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setUint32($1,$2,true)" js_unsafeSetUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setFloat32($1,$2,true)" js_unsafeSetFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +--JSU "$3.setFloat64($1,$2,true)" js_unsafeSetFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +-- +--JSS "$3.setInt8($1,$2)" js_setInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setUint8($1,$2)" js_setUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setInt16($1,$2)" js_setInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setInt32($1,$2)" js_setInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setUint16($1,$2)" js_setUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setUint32($1,$2)" js_setUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setFloat32($1,$2)" js_setFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setFloat64($1,$2)" js_setFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setInt16($1,$2,true)" js_setInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setInt32($1,$2,true)" js_setInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setUint16($1,$2,true)" js_setUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setUint32($1,$2,true)" js_setUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setFloat32($1,$2,true)" js_setFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +--JSS "$3.setFloat64($1,$2,true)" js_setFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) + diff --git a/src-ghc/JavaScript/TypedArray/Immutable.hs b/src-ghc/JavaScript/TypedArray/Immutable.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/TypedArray/Immutable.hs @@ -0,0 +1,1 @@ +module JavaScript.TypedArray.Immutable where diff --git a/src-ghc/JavaScript/TypedArray/Internal.hs b/src-ghc/JavaScript/TypedArray/Internal.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/TypedArray/Internal.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} + +module JavaScript.TypedArray.Internal where + +import Prelude hiding ((!!)) + +import GHC.Int +import GHC.Word + +import GHCJS.Internal.Types + +import Control.Monad (void) +import Control.Lens.Operators ((^.)) + +import GHCJS.Marshal (fromJSValUnchecked) + +import JavaScript.Array.Internal (SomeJSArray(..)) +import JavaScript.TypedArray.ArrayBuffer +import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..)) +import JavaScript.TypedArray.Internal.Types + +import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..)) +import Language.Javascript.JSaddle.Object (js, jsg, js1, js2, new, (!!), (<##)) + +elemSize :: SomeTypedArray e m -> GHCJSPure Int +elemSize (SomeTypedArray a) = GHCJSPure $ a ^. js "BYTES_PER_ELEMENT" >>= fromJSValUnchecked +{-# INLINE [1] elemSize #-} +{-# RULES "elemSizeUint8Clamped" forall (x :: SomeUint8ClampedArray m). elemSize x = GHCJSPure $ return 1 #-} +{-# RULES "elemSizeUint8" forall (x :: SomeUint8Array m). elemSize x = GHCJSPure $ return 1 #-} +{-# RULES "elemSizeUint16" forall (x :: SomeUint16Array m). elemSize x = GHCJSPure $ return 2 #-} +{-# RULES "elemSizeUint32" forall (x :: SomeUint32Array m). elemSize x = GHCJSPure $ return 4 #-} +{-# RULES "elemSizeInt8" forall (x :: SomeInt8Array m). elemSize x = GHCJSPure $ return 1 #-} +{-# RULES "elemSizeInt16" forall (x :: SomeInt16Array m). elemSize x = GHCJSPure $ return 2 #-} +{-# RULES "elemSizeInt32" forall (x :: SomeInt32Array m). elemSize x = GHCJSPure $ return 4 #-} +{-# RULES "elemSizeFloat32" forall (x :: SomeFloat32Array m). elemSize x = GHCJSPure $ return 4 #-} +{-# RULES "elemSizeFloat64" forall (x :: SomeFloat64Array m). elemSize x = GHCJSPure $ return 8 #-} + +instance TypedArray IOInt8Array where + index = indexI8 + unsafeIndex = unsafeIndexI8 + setIndex i x = setIndexI i (fromIntegral x) + unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x) + indexOf s x = indexOfI s (fromIntegral x) + lastIndexOf s x = lastIndexOfI s (fromIntegral x) + create l = SomeTypedArray <$> new (jsg "Int8Array") [l] + fromArray = int8ArrayFrom + fromArrayBuffer = undefined + +instance TypedArray IOInt16Array where + index = indexI16 + unsafeIndex = unsafeIndexI16 + setIndex i x = setIndexI i (fromIntegral x) + unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x) + indexOf s x = indexOfI s (fromIntegral x) + lastIndexOf s x = lastIndexOfI s (fromIntegral x) + create l = SomeTypedArray <$> new (jsg "Int16Array") [l] + fromArray = int16ArrayFrom + fromArrayBuffer = undefined + +instance TypedArray IOInt32Array where + index = indexI + unsafeIndex = unsafeIndexI + setIndex = setIndexI + unsafeSetIndex = unsafeSetIndexI + indexOf = indexOfI + lastIndexOf = lastIndexOfI + create l = SomeTypedArray <$> new (jsg "Int32Array") [l] + fromArray = int32ArrayFrom + fromArrayBuffer = undefined + +instance TypedArray IOUint8ClampedArray where + index = indexW8 + unsafeIndex = unsafeIndexW8 + setIndex i x = setIndexW i (fromIntegral x) + unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x) + indexOf s x = indexOfW s (fromIntegral x) + lastIndexOf s x = lastIndexOfW s (fromIntegral x) + create l = SomeTypedArray <$> new (jsg "Uint8ClampedArray") [l] + fromArray = uint8ClampedArrayFrom + fromArrayBuffer = undefined + +instance TypedArray IOUint8Array where + index = indexW8 + unsafeIndex = unsafeIndexW8 + setIndex i x = setIndexW i (fromIntegral x) + unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x) + indexOf s x = indexOfW s (fromIntegral x) + lastIndexOf s x = lastIndexOfW s (fromIntegral x) + create l = SomeTypedArray <$> new (jsg "Uint8Array") [l] + fromArray = uint8ArrayFrom + fromArrayBuffer = undefined + +instance TypedArray IOUint16Array where + index = indexW16 + unsafeIndex = unsafeIndexW16 + setIndex i x = setIndexW i (fromIntegral x) + unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x) + indexOf s x = indexOfW s (fromIntegral x) + lastIndexOf s x = lastIndexOfW s (fromIntegral x) + create l = SomeTypedArray <$> new (jsg "Uint16Array") [l] + fromArray = uint16ArrayFrom + fromArrayBuffer = undefined + +instance TypedArray IOUint32Array where + index = indexW + unsafeIndex = unsafeIndexW + setIndex = setIndexW + unsafeSetIndex = unsafeSetIndexW + indexOf = indexOfW + lastIndexOf = lastIndexOfW + create l = SomeTypedArray <$> new (jsg "Uint32Array") [l] + fromArray = uint32ArrayFrom + fromArrayBuffer = undefined + +instance TypedArray IOFloat32Array where + index = indexD + unsafeIndex = unsafeIndexD + setIndex = setIndexD + unsafeSetIndex = unsafeSetIndexD + indexOf = indexOfD + lastIndexOf = lastIndexOfD + create l = SomeTypedArray <$> new (jsg "Float32Array") [l] + fromArray = float32ArrayFrom + fromArrayBuffer = undefined + +instance TypedArray IOFloat64Array where + index = indexD + unsafeIndex = unsafeIndexD + setIndex = setIndexD + unsafeSetIndex = unsafeSetIndexD + indexOf = indexOfD + lastIndexOf = lastIndexOfD + create l = SomeTypedArray <$> new (jsg "Float64Array") [l] + fromArray = float64ArrayFrom + fromArrayBuffer = undefined + + +class TypedArray a where + unsafeIndex :: Int -> a -> JSM (Elem a) + index :: Int -> a -> JSM (Elem a) + unsafeSetIndex :: Int -> Elem a -> a -> JSM () + setIndex :: Int -> Elem a -> a -> JSM () + create :: Int -> JSM a + fromArray :: SomeJSArray m -> JSM a + fromArrayBuffer :: MutableArrayBuffer -> Int -> Maybe Int -> JSM a + indexOf :: Int -> Elem a -> a -> JSM Int + lastIndexOf :: Int -> Elem a -> a -> JSM Int + +-- ----------------------------------------------------------------------------- + +indexI :: Int -> SomeTypedArray e m -> JSM Int +indexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE indexI #-} + +indexI16 :: Int -> SomeTypedArray e m -> JSM Int16 +indexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE indexI16 #-} + +indexI8 :: Int -> SomeTypedArray e m -> JSM Int8 +indexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE indexI8 #-} + +indexW :: Int -> SomeTypedArray e m -> JSM Word +indexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE indexW #-} + +indexW16 :: Int -> SomeTypedArray e m -> JSM Word16 +indexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE indexW16 #-} + +indexW8 :: Int -> SomeTypedArray e m -> JSM Word8 +indexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE indexW8 #-} + +indexD :: Int -> SomeTypedArray e m -> JSM Double +indexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE indexD #-} + +-- ----------------------------------------------------------------------------- + +unsafeIndexI :: Int -> SomeTypedArray e m -> JSM Int +unsafeIndexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE unsafeIndexI #-} + +unsafeIndexI16 :: Int -> SomeTypedArray e m -> JSM Int16 +unsafeIndexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE unsafeIndexI16 #-} + +unsafeIndexI8 :: Int -> SomeTypedArray e m -> JSM Int8 +unsafeIndexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE unsafeIndexI8 #-} + +unsafeIndexW :: Int -> SomeTypedArray e m -> JSM Word +unsafeIndexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE unsafeIndexW #-} + +unsafeIndexW16 :: Int -> SomeTypedArray e m -> JSM Word16 +unsafeIndexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE unsafeIndexW16 #-} + +unsafeIndexW8 :: Int -> SomeTypedArray e m -> JSM Word8 +unsafeIndexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE unsafeIndexW8 #-} + +unsafeIndexD :: Int -> SomeTypedArray e m -> JSM Double +unsafeIndexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked +{-# INLINE unsafeIndexD #-} + +-- ----------------------------------------------------------------------------- + +int8ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt8Array m1) +int8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int8Array" ^. js1 "from" a +{-# INLINE int8ArrayFrom #-} + +int16ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt16Array m1) +int16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int16Array" ^. js1 "from" a +{-# INLINE int16ArrayFrom #-} + +int32ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt32Array m1) +int32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int32Array" ^. js1 "from" a +{-# INLINE int32ArrayFrom #-} + +uint8ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8Array m1) +uint8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8Array" ^. js1 "from" a +{-# INLINE uint8ArrayFrom #-} + +uint8ClampedArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8ClampedArray m1) +uint8ClampedArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8ClampedArray" ^. js1 "from" a +{-# INLINE uint8ClampedArrayFrom #-} + +uint16ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint16Array m1) +uint16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint16Array" ^. js1 "from" a +{-# INLINE uint16ArrayFrom #-} + +uint32ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint32Array m1) +uint32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint32Array" ^. js1 "from" a +{-# INLINE uint32ArrayFrom #-} + +float32ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat32Array m1) +float32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float32Array" ^. js1 "from" a +{-# INLINE float32ArrayFrom #-} + +float64ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat64Array m1) +float64ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float64Array" ^. js1 "from" a +{-# INLINE float64ArrayFrom #-} + +-- ----------------------------------------------------------------------------- + +setIndexI :: Mutability m ~ IsMutable + => Int -> Int -> SomeTypedArray e m -> JSM () +setIndexI i x (SomeTypedArray a) = (a <## i) x +{-# INLINE setIndexI #-} + +unsafeSetIndexI :: Mutability m ~ IsMutable + => Int -> Int -> SomeTypedArray e m -> JSM () +unsafeSetIndexI i x (SomeTypedArray a) = (a <## i) x +{-# INLINE unsafeSetIndexI #-} + +setIndexW :: Mutability m ~ IsMutable + => Int -> Word -> SomeTypedArray e m -> JSM () +setIndexW i x (SomeTypedArray a) = (a <## i) x +{-# INLINE setIndexW #-} + +unsafeSetIndexW :: Mutability m ~ IsMutable + => Int -> Word -> SomeTypedArray e m -> JSM () +unsafeSetIndexW i x (SomeTypedArray a) = (a <## i) x +{-# INLINE unsafeSetIndexW #-} + +setIndexD :: Mutability m ~ IsMutable + => Int -> Double -> SomeTypedArray e m -> JSM () +setIndexD i x (SomeTypedArray a) = (a <## i) x +{-# INLINE setIndexD #-} + +unsafeSetIndexD :: Mutability m ~ IsMutable + => Int -> Double -> SomeTypedArray e m -> JSM () +unsafeSetIndexD i x (SomeTypedArray a) = (a <## i) x +{-# INLINE unsafeSetIndexD #-} + +indexOfI :: Mutability m ~ IsMutable + => Int -> Int -> SomeTypedArray e m -> JSM Int +indexOfI s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked +{-# INLINE indexOfI #-} + +indexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int +indexOfW s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked +{-# INLINE indexOfW #-} + +indexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int +indexOfD s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked +{-# INLINE indexOfD #-} + +lastIndexOfI :: Int -> Int -> SomeTypedArray e m -> JSM Int +lastIndexOfI s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked +{-# INLINE lastIndexOfI #-} + +lastIndexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int +lastIndexOfW s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked +{-# INLINE lastIndexOfW #-} + +lastIndexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int +lastIndexOfD s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked +{-# INLINE lastIndexOfD #-} + +-- ----------------------------------------------------------------------------- +-- non-class operations usable for all typed array +{-| length of the typed array in elements -} +length :: SomeTypedArray e m -> GHCJSPure Int +length (SomeTypedArray a) = GHCJSPure $ a ^. js "length" >>= fromJSValUnchecked +{-# INLINE length #-} + +{-| length of the array in bytes -} +byteLength :: SomeTypedArray e m -> GHCJSPure Int +byteLength (SomeTypedArray a) = GHCJSPure $ a ^. js "byteLength" >>= fromJSValUnchecked +{-# INLINE byteLength #-} + +{-| offset of the array in the buffer -} +byteOffset :: SomeTypedArray e m -> GHCJSPure Int +byteOffset (SomeTypedArray a) = GHCJSPure $ a ^. js "byteOffset" >>= fromJSValUnchecked +{-# INLINE byteOffset #-} + +{-| the underlying buffer of the array -} +buffer :: SomeTypedArray e m -> GHCJSPure (SomeArrayBuffer m) +buffer (SomeTypedArray a) = GHCJSPure $ SomeArrayBuffer <$> a ^. js "buffer" +{-# INLINE buffer #-} + +{-| create a view of the existing array -} +subarray :: Int -> Int -> SomeTypedArray e m -> GHCJSPure (SomeTypedArray e m) +subarray begin end (SomeTypedArray a) = GHCJSPure$ SomeTypedArray <$> a ^. js2 "subarray" begin end +{-# INLINE subarray #-} + +-- fixme convert JSException to Haskell exception +{-| copy the elements of one typed array to another -} +set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure () +set offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src +{-# INLINE set #-} + +unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure () +unsafeSet offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src +{-# INLINE unsafeSet #-} + diff --git a/src-ghc/JavaScript/TypedArray/Internal/Types.hs b/src-ghc/JavaScript/TypedArray/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src-ghc/JavaScript/TypedArray/Internal/Types.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} + +module JavaScript.TypedArray.Internal.Types where + +import GHCJS.Types +import GHCJS.Internal.Types +import Language.Javascript.JSaddle (IsJSVal) + +import Data.Int +import Data.Typeable +import Data.Word + +newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) = + SomeTypedArray JSVal deriving Typeable +instance IsJSVal (SomeTypedArray e m) + +{- +newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal + deriving (Typeable) +-} + +type SomeSTTypedArray s (e :: TypedArrayElem) = SomeTypedArray e (STMutable s) + +-- ----------------------------------------------------------------------------- + +data TypedArrayElem = Int8Elem + | Int16Elem + | Int32Elem + | Uint8Elem + | Uint16Elem + | Uint32Elem + | Uint8ClampedElem + | Float32Elem + | Float64Elem + +-- ----------------------------------------------------------------------------- + +type SomeInt8Array = SomeTypedArray Int8Elem +type SomeInt16Array = SomeTypedArray Int16Elem +type SomeInt32Array = SomeTypedArray Int32Elem + +type SomeUint8Array = SomeTypedArray Uint8Elem +type SomeUint16Array = SomeTypedArray Uint16Elem +type SomeUint32Array = SomeTypedArray Uint32Elem + +type SomeFloat32Array = SomeTypedArray Float32Elem +type SomeFloat64Array = SomeTypedArray Float64Elem + +type SomeUint8ClampedArray = SomeTypedArray Uint8ClampedElem + +-- ----------------------------------------------------------------------------- + +type Int8Array = SomeInt8Array Immutable +type Int16Array = SomeInt16Array Immutable +type Int32Array = SomeInt32Array Immutable + +type Uint8Array = SomeUint8Array Immutable +type Uint16Array = SomeUint16Array Immutable +type Uint32Array = SomeUint32Array Immutable + +type Uint8ClampedArray = SomeUint8ClampedArray Immutable + +type Float32Array = SomeFloat32Array Immutable +type Float64Array = SomeFloat64Array Immutable + +-- ----------------------------------------------------------------------------- + +type IOInt8Array = SomeInt8Array Mutable +type IOInt16Array = SomeInt16Array Mutable +type IOInt32Array = SomeInt32Array Mutable + +type IOUint8Array = SomeUint8Array Mutable +type IOUint16Array = SomeUint16Array Mutable +type IOUint32Array = SomeUint32Array Mutable + +type IOUint8ClampedArray = SomeUint8ClampedArray Mutable + +type IOFloat32Array = SomeFloat32Array Mutable +type IOFloat64Array = SomeFloat64Array Mutable + +-- ----------------------------------------------------------------------------- + +type STInt8Array s = SomeSTTypedArray s Int8Elem +type STInt16Array s = SomeSTTypedArray s Int16Elem +type STInt32Array s = SomeSTTypedArray s Int32Elem + +type STUint8Array s = SomeSTTypedArray s Uint8Elem +type STUint16Array s = SomeSTTypedArray s Uint16Elem +type STUint32Array s = SomeSTTypedArray s Uint32Elem + +type STFloat32Array s = SomeSTTypedArray s Float32Elem +type STFloat64Array s = SomeSTTypedArray s Float64Elem + +type STUint8ClampedArray s = SomeSTTypedArray s Uint8ClampedElem + +-- ----------------------------------------------------------------------------- + +type family Elem x where + Elem (SomeUint8Array m) = Word8 + Elem (SomeUint8ClampedArray m) = Word8 + Elem (SomeUint16Array m) = Word16 + Elem (SomeUint32Array m) = Word + Elem (SomeInt8Array m) = Int8 + Elem (SomeInt16Array m) = Int16 + Elem (SomeInt32Array m) = Int + Elem (SomeFloat32Array m) = Double + Elem (SomeFloat64Array m) = Double + + Elem (STUint8Array s) = Word8 + Elem (STUint8ClampedArray s) = Word8 + Elem (STUint16Array s) = Word16 + Elem (STUint32Array s) = Word + Elem (STInt8Array s) = Int8 + Elem (STInt16Array s) = Int16 + Elem (STInt32Array s) = Int + Elem (STFloat32Array s) = Double + Elem (STFloat64Array s) = Double + diff --git a/src/Language/Javascript/JSaddle/Array.hs b/src/Language/Javascript/JSaddle/Array.hs deleted file mode 100644 --- a/src/Language/Javascript/JSaddle/Array.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Rank2Types #-} -#ifdef ghcjs_HOST_OS -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# OPTIONS_GHC -Wno-dodgy-exports -Wno-dodgy-imports #-} -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- --- Module : Language.Javascript.JSaddle.Object --- Copyright : (c) Hamish Mackenzie --- License : MIT --- --- Maintainer : Hamish Mackenzie --- --- | Interface to JavaScript array --- ------------------------------------------------------------------------------ - -module Language.Javascript.JSaddle.Array - ( SomeJSArray(..) - , JSArray - , MutableJSArray - , create - , length - , lengthIO - , nullIO - , fromListIO - , toListIO - , read - , write - , append - , push - , pop - , unshift - , shift - , reverse - , takeIO - , dropIO - , sliceIO - , freeze - , unsafeFreeze - , thaw - , unsafeThaw - ) where - -import Prelude hiding (read, reverse, null) -import Control.Monad (void) -import Language.Javascript.JSaddle.Types - (JSM, JSVal, SomeJSArray(..), JSArray, - MutableJSArray) -import Control.Lens.Operators ((^.)) -import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js) -import Language.Javascript.JSaddle.Value (valToNumber) -import JavaScript.Array.Internal (create, fromListIO, toListIO, read, push) - -lengthIO :: SomeJSArray m -> JSM Int -lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber) -{-# INLINE lengthIO #-} - -nullIO :: SomeJSArray m -> JSM Bool -nullIO = fmap (== 0) . lengthIO -{-# INLINE nullIO #-} - -append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1) -append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y -{-# INLINE append #-} - -write :: Int -> JSVal -> MutableJSArray -> JSM () -write n e (SomeJSArray x) = void $ (x ## n) e -{-# INLINE write #-} - -pop :: MutableJSArray -> JSM JSVal -pop (SomeJSArray x) = x ^. js0 "pop" -{-# INLINE pop #-} - -unshift :: JSVal -> MutableJSArray -> JSM () -unshift e (SomeJSArray x) = void $ x ^. js1 "unshift" e -{-# INLINE unshift #-} - -shift :: MutableJSArray -> JSM JSVal -shift (SomeJSArray x) = x ^. js0 "shift" -{-# INLINE shift #-} - -reverse :: MutableJSArray -> JSM () -reverse (SomeJSArray x) = void $ x ^. js0 "reverse" -{-# INLINE reverse #-} - -takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1) -takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n -{-# INLINE takeIO #-} - -dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1) -dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n -{-# INLINE dropIO #-} - -sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1) -sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n -{-# INLINE sliceIO #-} - -freeze :: MutableJSArray -> JSM JSArray -freeze (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice" (0::Int) -{-# INLINE freeze #-} - -unsafeFreeze :: MutableJSArray -> JSM JSArray -unsafeFreeze (SomeJSArray x) = pure (SomeJSArray x) -{-# INLINE unsafeFreeze #-} - -thaw :: JSArray -> JSM MutableJSArray -thaw (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice" (0::Int) -{-# INLINE thaw #-} - -unsafeThaw :: JSArray -> JSM MutableJSArray -unsafeThaw (SomeJSArray x) = pure (SomeJSArray x) -{-# INLINE unsafeThaw #-} - - diff --git a/src/Language/Javascript/JSaddle/Evaluate.hs b/src/Language/Javascript/JSaddle/Evaluate.hs --- a/src/Language/Javascript/JSaddle/Evaluate.hs +++ b/src/Language/Javascript/JSaddle/Evaluate.hs @@ -27,9 +27,7 @@ import Language.Javascript.JSaddle.Types (JSString) #else import Language.Javascript.JSaddle.Native.Internal - (withJSString) -import Language.Javascript.JSaddle.Run - (AsyncCommand(..), sendLazyCommand) + (evaluateScript) #endif import Language.Javascript.JSaddle.Marshal.String (ToJSString(..)) import Language.Javascript.JSaddle.Monad (JSM) @@ -55,7 +53,5 @@ foreign import javascript unsafe "$r = eval($1);" js_eval :: JSString -> IO JSVal #else -eval script = do - let rscript = toJSString script - withJSString rscript $ sendLazyCommand . EvaluateScript +eval = evaluateScript . toJSString #endif diff --git a/src/Language/Javascript/JSaddle/Exception.hs b/src/Language/Javascript/JSaddle/Exception.hs --- a/src/Language/Javascript/JSaddle/Exception.hs +++ b/src/Language/Javascript/JSaddle/Exception.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- @@ -17,7 +18,11 @@ ) where import qualified Control.Exception as E (Exception) -import Language.Javascript.JSaddle.Types (JSVal) +#ifdef ghcjs_HOST_OS +import GHCJS.Prim (JSVal) +#else +import GHCJS.Prim.Internal (JSVal) +#endif import Data.Typeable (Typeable) newtype JSException = JSException JSVal deriving (Typeable) diff --git a/src/Language/Javascript/JSaddle/Foreign.hs b/src/Language/Javascript/JSaddle/Foreign.hs deleted file mode 100644 --- a/src/Language/Javascript/JSaddle/Foreign.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- --- Module : Language.Javascript.JSaddle.Value --- Copyright : (c) Hamish Mackenzie --- License : MIT --- --- Maintainer : Hamish Mackenzie --- --- | This module is like `GHCJS.Foreign` but some functions are in --- ------------------------------------------------------------------------------ -module Language.Javascript.JSaddle.Foreign ( - jsTrue - , jsFalse - , jsNull - , toJSBool --- , fromJSBoolIO - , jsUndefined - , isTruthyIO - , isNullIO - , isUndefinedIO --- , isObjectIO --- , isFunctionIO --- , isStringIO --- , isBooleanIO --- , isSymbolIO --- , isNumberIO -) where - -#ifdef ghcjs_HOST_OS -import Language.Javascript.JSaddle.Types (JSM, JSVal) -import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined, jsTrue, jsFalse, isNull, isUndefined) -#else -import Language.Javascript.JSaddle.Types (JSM, JSVal(..)) -import Language.Javascript.JSaddle.Native.Internal - (withJSVal) -import Language.Javascript.JSaddle.Run - (Command(..), Result(..), sendCommand) -#endif - -#ifndef ghcjs_HOST_OS -jsTrue :: JSVal -jsTrue = JSVal 3 -{-# INLINE jsTrue #-} - -jsFalse :: JSVal -jsFalse = JSVal 2 -{-# INLINE jsFalse #-} - -jsNull :: JSVal -jsNull = JSVal 0 -{-# INLINE jsNull #-} - -toJSBool :: Bool -> JSVal -toJSBool b = JSVal $ if b then 3 else 2 -{-# INLINE toJSBool #-} - -jsUndefined :: JSVal -jsUndefined = JSVal 1 -{-# INLINE jsUndefined #-} -#endif - -isTruthyIO :: JSVal -> JSM Bool -#ifdef ghcjs_HOST_OS -isTruthyIO = return . isTruthy -#else -isTruthyIO (JSVal 0) = return False -- null -isTruthyIO (JSVal 1) = return False -- undefined -isTruthyIO (JSVal 2) = return False -- false -isTruthyIO (JSVal 3) = return True -- true -isTruthyIO v = withJSVal v $ \rval -> do - ValueToBoolResult result <- sendCommand (ValueToBool rval) - return result -#endif -{-# INLINE isTruthyIO #-} - -isNullIO :: JSVal -> JSM Bool -#ifdef ghcjs_HOST_OS -isNullIO = return . isNull -#else -isNullIO (JSVal 0) = return True -isNullIO v = withJSVal v $ \rval -> do - IsNullResult result <- sendCommand $ IsNull rval - return result -#endif -{-# INLINE isNullIO #-} - -isUndefinedIO :: JSVal -> JSM Bool -#ifdef ghcjs_HOST_OS -isUndefinedIO = return . isUndefined -#else -isUndefinedIO (JSVal 1) = return True -isUndefinedIO v = withJSVal v $ \rval -> do - IsUndefinedResult result <- sendCommand $ IsUndefined rval - return result -#endif -{-# INLINE isUndefinedIO #-} - diff --git a/src/Language/Javascript/JSaddle/Native.hs b/src/Language/Javascript/JSaddle/Native.hs --- a/src/Language/Javascript/JSaddle/Native.hs +++ b/src/Language/Javascript/JSaddle/Native.hs @@ -11,12 +11,7 @@ ----------------------------------------------------------------------------- module Language.Javascript.JSaddle.Native ( - wrapJSVal - , wrapJSString - , withJSVal - , withJSVals - , withObject - , withJSString + module Language.Javascript.JSaddle.Native.Internal , withToJSVal ) where diff --git a/src/Language/Javascript/JSaddle/Native/Internal.hs b/src/Language/Javascript/JSaddle/Native/Internal.hs --- a/src/Language/Javascript/JSaddle/Native/Internal.hs +++ b/src/Language/Javascript/JSaddle/Native/Internal.hs @@ -17,27 +17,46 @@ , withJSVals , withObject , withJSString + , setPropertyByName + , setPropertyAtIndex + , stringToValue + , numberToValue + , jsonValueToValue + , getPropertyByName + , getPropertyAtIndex + , callAsFunction + , callAsConstructor + , newEmptyObject + , newCallback + , newArray + , evaluateScript + , deRefVal + , valueToBool + , valueToNumber + , valueToString + , valueToJSON + , valueToJSONValue + , isNull + , isUndefined + , strictEqual + , instanceOf + , propertyNames ) where -import Control.Monad.Trans.Reader (ask) import Control.Monad.IO.Class (MonadIO(..)) -import Language.Javascript.JSaddle.Types - (JSContextRef(..), AsyncCommand(..), JSM(..), JSString(..), - Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..), - JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..)) -import System.Mem.Weak (addFinalizer) import Control.Monad.Primitive (touch) -import Control.Monad (when) -wrapJSVal :: JSValueReceived -> JSM JSVal -wrapJSVal (JSValueReceived ref) = do - -- TODO make sure this ref has not already been wrapped (perhaps only in debug version) - let result = JSVal ref - when (ref >= 5) $ do - ctx <- JSM ask - liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref - return result +import Data.Aeson (Value) +import Language.Javascript.JSaddle.Types + (AsyncCommand(..), JSM(..), JSString(..), addCallback, + Object(..), JSVal(..), JSValueForSend(..), JSCallAsFunction, + JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..)) +import Language.Javascript.JSaddle.Monad (askJSM) +import Language.Javascript.JSaddle.Run + (Command(..), AsyncCommand(..), Result(..), sendCommand, + sendAsyncCommand, sendLazyCommand, wrapJSVal) + wrapJSString :: MonadIO m => JSStringReceived -> m JSString wrapJSString (JSStringReceived ref) = return $ JSString ref @@ -62,3 +81,149 @@ liftIO $ touch v return result +setPropertyByName :: JSString -> JSVal -> Object -> JSM () +setPropertyByName name val this = + withObject this $ \rthis -> + withJSString name $ \rname -> + withJSVal val $ \rval -> + sendAsyncCommand $ SetPropertyByName rthis rname rval +{-# INLINE setPropertyByName #-} + +setPropertyAtIndex :: Int -> JSVal -> Object -> JSM () +setPropertyAtIndex index val this = + withObject this $ \rthis -> + withJSVal val $ \rval -> + sendAsyncCommand $ SetPropertyAtIndex rthis index rval +{-# INLINE setPropertyAtIndex #-} + +stringToValue :: JSString -> JSM JSVal +stringToValue s = withJSString s $ sendLazyCommand . StringToValue +{-# INLINE stringToValue #-} + +numberToValue :: Double -> JSM JSVal +numberToValue = sendLazyCommand . NumberToValue +{-# INLINE numberToValue #-} + +jsonValueToValue :: Value -> JSM JSVal +jsonValueToValue = sendLazyCommand . JSONValueToValue +{-# INLINE jsonValueToValue #-} + +getPropertyByName :: JSString -> Object -> JSM JSVal +getPropertyByName name this = + withObject this $ \rthis -> + withJSString name $ sendLazyCommand . GetPropertyByName rthis +{-# INLINE getPropertyByName #-} + +getPropertyAtIndex :: Int -> Object -> JSM JSVal +getPropertyAtIndex index this = + withObject this $ \rthis -> sendLazyCommand $ GetPropertyAtIndex rthis index +{-# INLINE getPropertyAtIndex #-} + +callAsFunction :: Object -> Object -> [JSVal] -> JSM JSVal +callAsFunction f this args = + withObject f $ \rfunction -> + withObject this $ \rthis -> + withJSVals args $ sendLazyCommand . CallAsFunction rfunction rthis +{-# INLINE callAsFunction #-} + +callAsConstructor :: Object -> [JSVal] -> JSM JSVal +callAsConstructor f args = + withObject f $ \rfunction -> + withJSVals args $ sendLazyCommand . CallAsConstructor rfunction +{-# INLINE callAsConstructor #-} + +newEmptyObject :: JSM Object +newEmptyObject = Object <$> sendLazyCommand NewEmptyObject +{-# INLINE newEmptyObject #-} + +newCallback :: JSCallAsFunction -> JSM Object +newCallback f = do + object <- Object <$> sendLazyCommand NewCallback + add <- addCallback <$> askJSM + liftIO $ add object f + return object +{-# INLINE newCallback #-} + +newArray :: [JSVal] -> JSM JSVal +newArray xs = withJSVals xs $ \xs' -> sendLazyCommand (NewArray xs') +{-# INLINE newArray #-} + +evaluateScript :: JSString -> JSM JSVal +evaluateScript script = withJSString script $ sendLazyCommand . EvaluateScript +{-# INLINE evaluateScript #-} + +deRefVal :: JSVal -> JSM Result +deRefVal value = withJSVal value $ sendCommand . DeRefVal +{-# INLINE deRefVal #-} + +valueToBool :: JSVal -> JSM Bool +valueToBool (JSVal 0) = return False -- null +valueToBool (JSVal 1) = return False -- undefined +valueToBool (JSVal 2) = return False -- false +valueToBool (JSVal 3) = return True -- true +valueToBool v = withJSVal v $ \rval -> do + ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval) + return result +{-# INLINE valueToBool #-} + +valueToNumber :: JSVal -> JSM Double +valueToNumber value = + withJSVal value $ \rval -> do + ~(ValueToNumberResult result) <- sendCommand (ValueToNumber rval) + return result +{-# INLINE valueToNumber #-} + +valueToString :: JSVal -> JSM JSString +valueToString value = withJSVal value $ \rval -> do + ~(ValueToStringResult result) <- sendCommand (ValueToString rval) + wrapJSString result +{-# INLINE valueToString #-} + +valueToJSON :: JSVal -> JSM JSString +valueToJSON value = withJSVal value $ \rval -> do + ~(ValueToJSONResult result) <- sendCommand (ValueToJSON rval) + wrapJSString result +{-# INLINE valueToJSON #-} + +valueToJSONValue :: JSVal -> JSM Value +valueToJSONValue value = withJSVal value $ \rval -> do + ~(ValueToJSONValueResult result) <- sendCommand (ValueToJSONValue rval) + return result +{-# INLINE valueToJSONValue #-} + +isNull :: JSVal -> JSM Bool +isNull (JSVal 0) = return True +isNull v = withJSVal v $ \rval -> do + ~(IsNullResult result) <- sendCommand $ IsNull rval + return result +{-# INLINE isNull #-} + +isUndefined :: JSVal -> JSM Bool +isUndefined (JSVal 1) = return True +isUndefined v = withJSVal v $ \rval -> do + ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval + return result +{-# INLINE isUndefined #-} + +strictEqual :: JSVal -> JSVal -> JSM Bool +strictEqual a b = + withJSVal a $ \aref -> + withJSVal b $ \bref -> do + ~(StrictEqualResult result) <- sendCommand $ StrictEqual aref bref + return result +{-# INLINE strictEqual #-} + +instanceOf :: JSVal -> Object -> JSM Bool +instanceOf value constructor = + withJSVal value $ \rval -> + withObject constructor $ \c' -> do + ~(InstanceOfResult result) <- sendCommand $ InstanceOf rval c' + return result +{-# INLINE instanceOf #-} + +propertyNames :: Object -> JSM [JSString] +propertyNames this = + withObject this $ \rthis -> do + ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis + mapM wrapJSString result +{-# INLINE propertyNames #-} diff --git a/src/Language/Javascript/JSaddle/Object.hs b/src/Language/Javascript/JSaddle/Object.hs --- a/src/Language/Javascript/JSaddle/Object.hs +++ b/src/Language/Javascript/JSaddle/Object.hs @@ -113,12 +113,9 @@ (JSString, Object(..), JSVal(..), JSCallAsFunction) #else -import Data.Text (Text) import GHCJS.Marshal.Internal (ToJSVal(..)) import Language.Javascript.JSaddle.Native - (withJSVals, withObject) -import Language.Javascript.JSaddle.Run - (AsyncCommand(..), sendLazyCommand) + (newCallback, callAsFunction, callAsConstructor) import Language.Javascript.JSaddle.Monad (askJSM, JSM) import Language.Javascript.JSaddle.Types (JSString, Object(..), SomeJSArray(..), @@ -280,6 +277,7 @@ -- > jsg0 name = jsgf name () -- -- >>> testJSaddle $ jsg0 "globalFunc" >>= valToText +-- A JavaScript exception was thrown! (may not reach Haskell code) -- TypeError:...undefine... jsg0 :: (ToJSString name) => name -> JSM JSVal jsg0 name = jsgf name () @@ -451,9 +449,7 @@ makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object #else function f = do - object <- Object <$> sendLazyCommand NewCallback - add <- addCallback <$> askJSM - liftIO $ add object f + object <- newCallback f return $ Function object #endif @@ -533,9 +529,7 @@ #else objCallAsFunction f this args = do rargs <- makeArgs args - withObject f $ \rfunction -> - withObject this $ \rthis -> - withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis + callAsFunction f this rargs #endif -- | Call a JavaScript object as a constructor. Consider using 'new'. @@ -577,8 +571,7 @@ #else objCallAsConstructor f args = do rargs <- makeArgs args - withObject f $ \rfunction -> - withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction + callAsConstructor f rargs #endif -- >>> testJSaddle $ strictEqual nullObject (eval "null") diff --git a/src/Language/Javascript/JSaddle/Run.hs b/src/Language/Javascript/JSaddle/Run.hs --- a/src/Language/Javascript/JSaddle/Run.hs +++ b/src/Language/Javascript/JSaddle/Run.hs @@ -28,6 +28,7 @@ , sendCommand , sendLazyCommand , sendAsyncCommand + , wrapJSVal #endif ) where @@ -37,10 +38,10 @@ (waitForAnimationFrame) #else import Control.Exception (throwIO) -import Control.Monad (void, forever) +import Control.Monad (void, when, forever, zipWithM_) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask, runReaderT) -import Control.Monad.STM (STM, atomically) +import Control.Monad.STM (atomically) import Control.Concurrent (forkIO) import Control.Concurrent.STM.TChan (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO) @@ -49,16 +50,20 @@ import Control.Concurrent.MVar (MVar, MVar, putMVar, takeMVar, newEmptyMVar) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Mem.Weak (addFinalizer) + import Data.Monoid ((<>)) import qualified Data.Text as T (unpack) import qualified Data.Map as M (lookup, delete, insert, empty) import Data.Time.Clock (getCurrentTime,diffUTCTime) import Language.Javascript.JSaddle.Types - (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..), + (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..), Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..)) import Language.Javascript.JSaddle.Exception (JSException(..)) -import Language.Javascript.JSaddle.Native.Internal (wrapJSVal) +-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal) +import Control.DeepSeq (deepseq) #endif -- | Forces execution of pending asyncronous code @@ -66,7 +71,9 @@ #ifdef ghcjs_HOST_OS syncPoint = return () #else -syncPoint = void $ sendCommand Sync +syncPoint = do + SyncResult <- sendCommand Sync + return () #endif -- | Forces execution of pending asyncronous code after performing `f` @@ -126,7 +133,7 @@ s <- doSendAsyncCommand <$> JSM ask liftIO $ s cmd -runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Result -> IO (), IO ()) +runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ()) runJavaScript sendBatch entryPoint = do startTime' <- getCurrentTime recvChan <- newTChanIO @@ -135,18 +142,19 @@ nextRef' <- newTVarIO 0 let ctx = JSContextRef { startTime = startTime' - , doSendCommand = \cmd -> do + , doSendCommand = \cmd -> cmd `deepseq` do result <- newEmptyMVar atomically $ writeTChan commandChan (Right (cmd, result)) - takeMVar result >>= \case - (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v) - r -> return r - , doSendAsyncCommand = atomically . writeTChan commandChan . Left + unsafeInterleaveIO $ + takeMVar result >>= \case + (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v) + r -> return r + , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd) , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb) , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val) , nextRef = nextRef' } - let processResult = \case + let processResults = \case (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err (Callback f this a) -> do f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx @@ -157,40 +165,52 @@ Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx m -> atomically $ writeTChan recvChan m _ <- forkIO . forever $ readBatch commandChan >>= \case - (batch, Just resultMVar) -> do - sendBatch batch - atomically (readTChan recvChan) >>= putMVar resultMVar - (batch, Nothing) -> do + (batch, resultMVars) -> do sendBatch batch atomically (readTChan recvChan) >>= \case - SyncResult -> return () - ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e) - _ -> error "Unexpected result processing batch" - return () - return (processResult, runReaderT (unJSM entryPoint) ctx) + Success results -> zipWithM_ putMVar resultMVars results + Failure results exception -> do + -- The exception will only be rethrown in Haskell if/when one of the + -- missing results (if any) is evaluated. + putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)" + zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception) + _ -> error "Unexpected jsaddle results" + return (processResults, runReaderT (unJSM entryPoint) ctx) where - readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, Maybe (MVar Result)) + readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result]) readBatch chan = do first <- atomically $ readTChan chan -- We want at least one command to send - loop first [] + loop first ([], []) where - loop (Left asyncCmd@(SyncWithAnimationFrame _)) asyncCmds = - atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds) - loop (Right (cmd, resultMVar)) asyncCmds = - return (Batch (reverse asyncCmds) cmd False, Just resultMVar) - loop (Left asyncCmd) asyncCmds' = do - let asyncCmds = asyncCmd:asyncCmds' + loop :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result]) + loop (Left asyncCmd@(SyncWithAnimationFrame _)) (cmds, resultMVars) = + atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars) + loop (Right (syncCmd, resultMVar)) (cmds', resultMVars') = do + let cmds = Right syncCmd:cmds' + resultMVars = resultMVar:resultMVars' atomically (tryReadTChan chan) >>= \case - Nothing -> return (Batch (reverse asyncCmds) Sync False, Nothing) - Just cmd -> loop cmd asyncCmds + Nothing -> return (Batch (reverse cmds) False, reverse resultMVars) + Just cmd -> loop cmd (cmds, resultMVars) + loop (Left asyncCmd) (cmds', resultMVars) = do + let cmds = Left asyncCmd:cmds' + atomically (tryReadTChan chan) >>= \case + Nothing -> return (Batch (reverse cmds) False, reverse resultMVars) + Just cmd -> loop cmd (cmds, resultMVars) -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch - loopAnimation (Right (cmd, resultMVar)) asyncCmds = - return (Batch (reverse asyncCmds) cmd True, Just resultMVar) - loopAnimation (Left asyncCmd) asyncCmds = - atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds) - discardToSyncPoint :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (MVar Result) - discardToSyncPoint chan = - readTChan chan >>= \case - Right (_, resultMVar) -> return resultMVar - _ -> discardToSyncPoint chan + loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result]) + loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) = + return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars)) + loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) = + atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars) + loopAnimation (Left asyncCmd) (cmds, resultMVars) = + atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars) + +wrapJSVal :: JSValueReceived -> JSM JSVal +wrapJSVal (JSValueReceived ref) = do + -- TODO make sure this ref has not already been wrapped (perhaps only in debug version) + let result = JSVal ref + when (ref >= 5) $ do + ctx <- JSM ask + liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref + return result #endif diff --git a/src/Language/Javascript/JSaddle/Run/Files.hs b/src/Language/Javascript/JSaddle/Run/Files.hs --- a/src/Language/Javascript/JSaddle/Run/Files.hs +++ b/src/Language/Javascript/JSaddle/Run/Files.hs @@ -47,12 +47,15 @@ runBatch :: (ByteString -> ByteString) -> ByteString runBatch send = "\ - \ var processBatch = function(timestamp) {\n\ - \ try {\n\ - \ var nAsyncLength = batch[0].length;\n\ - \ for (var nAsync = 0; nAsync != nAsyncLength; nAsync++) {\n\ - \ var d = batch[0][nAsync];\n\ - \ switch (d.tag) {\n\ + \ var processBatch = function(timestamp) {\n\ + \ var results = [];\n\ + \ try {\n\ + \ var nCommandsLength = batch[0].length;\n\ + \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\ + \ var cmd = batch[0][nCommand];\n\ + \ if (cmd.Left) {\n\ + \ var d = cmd.Left;\n\ + \ switch (d.tag) {\n\ \ case \"FreeRef\":\n\ \ jsaddle_values.delete(d.contents);\n\ \ break;\n\ @@ -148,76 +151,79 @@ \ default:\n\ \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\ \ return;\n\ - \ }\n\ \ }\n\ - \ var d = batch[1];\n\ + \ } else {\n\ + \ var d = cmd.Right;\n\ \ switch (d.tag) {\n\ - \ case \"ValueToString\":\n\ - \ var val = jsaddle_values.get(d.contents);\n\ - \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\ - \ " <> send "{\"tag\": \"ValueToStringResult\", \"contents\": s}" <> "\n\ - \ break;\n\ - \ case \"ValueToBool\":\n\ - \ " <> send "{\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false}" <> "\n\ - \ break;\n\ - \ case \"ValueToNumber\":\n\ - \ " <> send "{\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))}" <> "\n\ - \ break;\n\ - \ case \"ValueToJSON\":\n\ - \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\ - \ " <> send "{\"tag\": \"ValueToJSONResult\", \"contents\": s}" <> "\n\ - \ break;\n\ - \ case \"ValueToJSONValue\":\n\ - \ " <> send "{\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)}" <> "\n\ - \ break;\n\ - \ case \"DeRefVal\":\n\ - \ var n = d.contents;\n\ - \ var v = jsaddle_values.get(n);\n\ - \ var c = (v === null ) ? [0, \"\"] :\n\ - \ (v === undefined ) ? [1, \"\"] :\n\ - \ (v === false ) ? [2, \"\"] :\n\ - \ (v === true ) ? [3, \"\"] :\n\ - \ (typeof v === \"number\") ? [-1, v.toString()] :\n\ - \ (typeof v === \"string\") ? [-2, v]\n\ - \ : [n, \"\"];\n\ - \ " <> send "{\"tag\": \"DeRefValResult\", \"contents\": c}" <> "\n\ - \ break;\n\ - \ case \"IsNull\":\n\ - \ " <> send "{\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null}" <> "\n\ - \ break;\n\ - \ case \"IsUndefined\":\n\ - \ " <> send "{\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined}" <> "\n\ - \ break;\n\ - \ case \"InstanceOf\":\n\ - \ " <> send "{\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])}" <> "\n\ - \ break;\n\ - \ case \"StrictEqual\":\n\ - \ " <> send "{\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])}" <> "\n\ - \ break;\n\ - \ case \"PropertyNames\":\n\ - \ var result = [];\n\ - \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\ - \ " <> send "{\"tag\": \"PropertyNamesResult\", \"contents\": result}" <> "\n\ - \ break;\n\ - \ case \"Sync\":\n\ - \ " <> send "{\"tag\": \"SyncResult\", \"contents\": []}" <> "\n\ - \ break;\n\ - \ default:\n\ - \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\ - \ }\n\ - \ }\n\ - \ catch (err) {\n\ - \ var n = ++jsaddle_index;\n\ - \ jsaddle_values.set(n, err);\n\ - \ " <> send "{\"tag\": \"ThrowJSValue\", \"contents\": n}" <> "\n\ + \ case \"ValueToString\":\n\ + \ var val = jsaddle_values.get(d.contents);\n\ + \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\ + \ results.push({\"tag\": \"ValueToStringResult\", \"contents\": s});\n\ + \ break;\n\ + \ case \"ValueToBool\":\n\ + \ results.push({\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false});\n\ + \ break;\n\ + \ case \"ValueToNumber\":\n\ + \ results.push({\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))});\n\ + \ break;\n\ + \ case \"ValueToJSON\":\n\ + \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\ + \ results.push({\"tag\": \"ValueToJSONResult\", \"contents\": s});\n\ + \ break;\n\ + \ case \"ValueToJSONValue\":\n\ + \ results.push({\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)});\n\ + \ break;\n\ + \ case \"DeRefVal\":\n\ + \ var n = d.contents;\n\ + \ var v = jsaddle_values.get(n);\n\ + \ var c = (v === null ) ? [0, \"\"] :\n\ + \ (v === undefined ) ? [1, \"\"] :\n\ + \ (v === false ) ? [2, \"\"] :\n\ + \ (v === true ) ? [3, \"\"] :\n\ + \ (typeof v === \"number\") ? [-1, v.toString()] :\n\ + \ (typeof v === \"string\") ? [-2, v]\n\ + \ : [n, \"\"];\n\ + \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\ + \ break;\n\ + \ case \"IsNull\":\n\ + \ results.push({\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null});\n\ + \ break;\n\ + \ case \"IsUndefined\":\n\ + \ results.push({\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined});\n\ + \ break;\n\ + \ case \"InstanceOf\":\n\ + \ results.push({\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])});\n\ + \ break;\n\ + \ case \"StrictEqual\":\n\ + \ results.push({\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])});\n\ + \ break;\n\ + \ case \"PropertyNames\":\n\ + \ var result = [];\n\ + \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\ + \ results.push({\"tag\": \"PropertyNamesResult\", \"contents\": result});\n\ + \ break;\n\ + \ case \"Sync\":\n\ + \ results.push({\"tag\": \"SyncResult\", \"contents\": []});\n\ + \ break;\n\ + \ default:\n\ + \ results.push({\"tag\": \"ProtocolError\", \"contents\": e.data});\n\ + \ }\n\ \ }\n\ - \ };\n\ - \ if(batch[2]) {\n\ - \ window.requestAnimationFrame(processBatch);\n\ \ }\n\ - \ else {\n\ - \ processBatch(window.performance ? window.performance.now() : null);\n\ - \ }\n\ + \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\ + \ }\n\ + \ catch (err) {\n\ + \ var n = ++jsaddle_index;\n\ + \ jsaddle_values.set(n, err);\n\ + \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\ + \ }\n\ + \ };\n\ + \ if(batch[1]) {\n\ + \ window.requestAnimationFrame(processBatch);\n\ + \ }\n\ + \ else {\n\ + \ processBatch(window.performance ? window.performance.now() : null);\n\ + \ }\n\ \" -- Use this to generate this string for embedding @@ -322,5 +328,59 @@ \ }\n\ \ }\n\ \\n\ + \}\n\ + \function h$roundUpToMultipleOf(n,m) {\n\ + \ var rem = n % m;\n\ + \ return rem === 0 ? n : n - rem + m;\n\ + \}\n\ + \\n\ + \function h$newByteArray(len) {\n\ + \ var len0 = Math.max(h$roundUpToMultipleOf(len, 8), 8);\n\ + \ var buf = new ArrayBuffer(len0);\n\ + \ return { buf: buf\n\ + \ , len: len\n\ + \ , i3: new Int32Array(buf)\n\ + \ , u8: new Uint8Array(buf)\n\ + \ , u1: new Uint16Array(buf)\n\ + \ , f3: new Float32Array(buf)\n\ + \ , f6: new Float64Array(buf)\n\ + \ , dv: new DataView(buf)\n\ + \ }\n\ + \}\n\ + \function h$wrapBuffer(buf, unalignedOk, offset, length) {\n\ + \ if(!unalignedOk && offset && offset % 8 !== 0) {\n\ + \ throw (\"h$wrapBuffer: offset not aligned:\" + offset);\n\ + \ }\n\ + \ if(!buf || !(buf instanceof ArrayBuffer))\n\ + \ throw \"h$wrapBuffer: not an ArrayBuffer\"\n\ + \ if(!offset) { offset = 0; }\n\ + \ if(!length || length < 0) { length = buf.byteLength - offset; }\n\ + \ return { buf: buf\n\ + \ , len: length\n\ + \ , i3: (offset%4) ? null : new Int32Array(buf, offset, length >> 2)\n\ + \ , u8: new Uint8Array(buf, offset, length)\n\ + \ , u1: (offset%2) ? null : new Uint16Array(buf, offset, length >> 1)\n\ + \ , f3: (offset%4) ? null : new Float32Array(buf, offset, length >> 2)\n\ + \ , f6: (offset%8) ? null : new Float64Array(buf, offset, length >> 3)\n\ + \ , dv: new DataView(buf, offset, length)\n\ + \ };\n\ + \}\n\ + \function h$newByteArrayFromBase64String(base64) {\n\ + \ var bin = window.atob(base64);\n\ + \ var ba = h$newByteArray(bin.length);\n\ + \ var u8 = ba.u8;\n\ + \ for (var i = 0; i < bin.length; i++) {\n\ + \ u8[i] = bin.charCodeAt(i);\n\ + \ }\n\ + \ return ba;\n\ + \}\n\ + \function h$byteArrayToBase64String(off, len, ba) {\n\ + \ var bin = '';\n\ + \ var u8 = ba.u8;\n\ + \ var end = off + len;\n\ + \ for (var i = off; i < end; i++) {\n\ + \ bin += String.fromCharCode(u8[i]);\n\ + \ }\n\ + \ return window.btoa(bin);\n\ \}\n\ \" diff --git a/src/Language/Javascript/JSaddle/Types.hs b/src/Language/Javascript/JSaddle/Types.hs --- a/src/Language/Javascript/JSaddle/Types.hs +++ b/src/Language/Javascript/JSaddle/Types.hs @@ -7,11 +7,11 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} #endif ----------------------------------------------------------------------------- -- @@ -34,11 +34,20 @@ , MonadJSM(..) , liftJSM + -- * Pure GHCJS functions + , GHCJSPure(..) + , ghcjsPure + , ghcjsPureMap + , ghcjsPureId + -- * JavaScript Value Types , JSVal(..) + , IsJSVal(..) + , jsval , SomeJSArray(..) , JSArray , MutableJSArray + , STJSArray , Object(..) , JSString(..) , Nullable(..) @@ -46,6 +55,11 @@ -- * JavaScript Context Commands #ifndef ghcjs_HOST_OS + , MutabilityType(..) + , Mutable + , Immutable + , IsItMutable(..) + , Mutability , JSValueReceived(..) , JSValueForSend(..) , JSStringReceived(..) @@ -55,6 +69,7 @@ , Command(..) , Batch(..) , Result(..) + , Results(..) #endif ) where @@ -62,9 +77,11 @@ #ifdef ghcjs_HOST_OS import GHCJS.Types import JavaScript.Object.Internal (Object(..)) -import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray) +import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray, STJSArray) import GHCJS.Nullable (Nullable(..)) #else +import GHCJS.Prim.Internal (JSVal(..), JSValueRef) +import Data.JSString.Internal.Type (JSString(..)) import Control.DeepSeq (NFData(..)) import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.State.Lazy (StateT(..)) @@ -74,11 +91,10 @@ import Control.Monad.Fix (MonadFix) import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..)) import Control.Concurrent.STM.TVar (TVar) -import Data.Coerce (Coercible, coerce) -import Data.Int (Int64) import Data.Text (Text) import Data.Time.Clock (UTCTime(..)) import Data.Typeable (Typeable) +import Data.Coerce (coerce, Coercible) import Data.Aeson (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value) import GHC.Generics (Generic) @@ -116,6 +132,47 @@ deriving (Functor, Applicative, Monad, MonadIO, MonadFix) #endif + +-- | Type we can give to functions that are pure when using ghcjs, but +-- live in JSM when using jsaddle. +-- +-- Some functions that can be pure in GHCJS cannot be implemented in +-- a pure way in JSaddle (because we need to know the JSContextRef). +-- Instead we implement versions of these functions in that return +-- `GHCJSPure a` instead of `a`. To call them in a way that will +-- work when compiling with GHCJS use `ghcjsPure`. +#ifdef ghcjs_HOST_OS +type GHCJSPure a = a +#else +newtype GHCJSPure a = GHCJSPure (JSM a) +#endif + +-- | Used when you want to call a functions that is pure in GHCJS, but +-- lives in the JSM in jsaddle. +ghcjsPure :: GHCJSPure a -> JSM a +#ifdef ghcjs_HOST_OS +ghcjsPure = pure +#else +ghcjsPure (GHCJSPure x) = x +#endif +{-# INLINE ghcjsPure #-} + +ghcjsPureMap :: (a -> b) -> GHCJSPure a -> GHCJSPure b +#ifdef ghcjs_HOST_OS +ghcjsPureMap = id +#else +ghcjsPureMap f (GHCJSPure x) = GHCJSPure (f <$> x) +#endif +{-# INLINE ghcjsPureMap #-} + +ghcjsPureId :: a -> GHCJSPure a +#ifdef ghcjs_HOST_OS +ghcjsPureId = id +#else +ghcjsPureId = GHCJSPure . return +#endif +{-# INLINE ghcjsPureId #-} + -- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'. -- When using GHCJS it is 'MonadIO'. #ifdef ghcjs_HOST_OS @@ -172,23 +229,15 @@ -- as an argument and invoke it from haskell. #ifndef ghcjs_HOST_OS --- A reference to a particular JavaScript value inside the JavaScript context -type JSValueRef = Int64 --- | See 'GHCJS.Prim.JSVal' -newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON) - -instance NFData JSVal where - rnf x = x `seq` () - class IsJSVal a where - jsval_ :: a -> JSVal + jsval_ :: a -> GHCJSPure JSVal - default jsval_ :: Coercible a JSVal => a -> JSVal - jsval_ = coerce + default jsval_ :: Coercible a JSVal => a -> GHCJSPure JSVal + jsval_ = GHCJSPure . return . coerce {-# INLINE jsval_ #-} -jsval :: IsJSVal a => a -> JSVal +jsval :: IsJSVal a => a -> GHCJSPure JSVal jsval = jsval_ {-# INLINE jsval #-} @@ -209,35 +258,39 @@ newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal deriving (Typeable) +instance IsJSVal (SomeJSArray m) -- | See 'JavaScript.Array.Internal.JSArray' type JSArray = SomeJSArray Immutable -- | See 'JavaScript.Array.Internal.MutableJSArray' type MutableJSArray = SomeJSArray Mutable +-- | See 'JavaScript.Array.Internal.STJSArray' +type STJSArray s = SomeJSArray (STMutable s) + -- | See 'JavaScript.Object.Internal.Object' newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON) -- | See 'GHCJS.Nullable.Nullable' newtype Nullable a = Nullable a --- | See 'Data.JSString.Internal.Type' -newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON) - -- | Wrapper used when receiving a 'JSVal' from the JavaScript context newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON) -- | Wrapper used when sending a 'JSVal' to the JavaScript context -newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON) +newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON, Generic) +instance NFData JSValueForSend -- | Wrapper used when sending a 'Object' to the JavaScript context -newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON) +newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON, Generic) +instance NFData JSObjectForSend -- | Wrapper used when receiving a 'JSString' from the JavaScript context newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON) -- | Wrapper used when sending a 'JString' to the JavaScript context -newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON) +newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON, Generic) +instance NFData JSStringForSend -- | Command sent to a JavaScript context for execution asynchronously data AsyncCommand = FreeRef JSValueForSend @@ -255,13 +308,15 @@ | NewArray [JSValueForSend] JSValueForSend | EvaluateScript JSStringForSend JSValueForSend | SyncWithAnimationFrame JSValueForSend - deriving (Show, Generic) + deriving (Show, Generic) instance ToJSON AsyncCommand where toEncoding = genericToEncoding defaultOptions instance FromJSON AsyncCommand +instance NFData AsyncCommand + -- | Command sent to a JavaScript context for execution synchronously data Command = DeRefVal JSValueForSend | ValueToBool JSValueForSend @@ -282,8 +337,10 @@ instance FromJSON Command +instance NFData Command + -- | Batch of commands that can be sent together to the JavaScript context -data Batch = Batch [AsyncCommand] Command Bool +data Batch = Batch [Either AsyncCommand Command] Bool deriving (Show, Generic) instance ToJSON Batch where @@ -291,6 +348,8 @@ instance FromJSON Batch +instance NFData Batch + -- | Result of a 'Command' returned from the JavaScript context data Result = DeRefValResult JSValueRef Text | ValueToBoolResult Bool @@ -302,17 +361,26 @@ | IsUndefinedResult Bool | StrictEqualResult Bool | InstanceOfResult Bool - | Callback JSValueReceived JSValueReceived [JSValueReceived] | PropertyNamesResult [JSStringReceived] | ThrowJSValue JSValueReceived - | ProtocolError Text | SyncResult - deriving (Show, Generic) + deriving (Show, Generic) instance ToJSON Result where toEncoding = genericToEncoding defaultOptions instance FromJSON Result + +data Results = Success [Result] + | Failure [Result] JSValueReceived + | Callback JSValueReceived JSValueReceived [JSValueReceived] + | ProtocolError Text + deriving (Show, Generic) + +instance ToJSON Results where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON Results #endif diff --git a/src/Language/Javascript/JSaddle/Value.hs b/src/Language/Javascript/JSaddle/Value.hs --- a/src/Language/Javascript/JSaddle/Value.hs +++ b/src/Language/Javascript/JSaddle/Value.hs @@ -45,7 +45,7 @@ , showJSValue -- * Converting JavaScript values - , isTruthyIO + , isTruthy , valToBool , valToNumber , valToStr @@ -57,11 +57,11 @@ , val , jsNull , valNull - , isNullIO + , isNull , valIsNull , jsUndefined , valUndefined - , isUndefinedIO + , isUndefined , valIsUndefined , maybeNullOrUndefined , maybeNullOrUndefined' @@ -84,32 +84,32 @@ import Data.Text (Text) import qualified Data.Text as T (pack, unpack) import Data.Aeson (Value) +import Data.JSString.Text (textToJSString) #ifdef ghcjs_HOST_OS import Language.Javascript.JSaddle.Types - (Object(..), JSString(..), JSVal(..)) + (Object(..), JSString(..), JSVal(..), ghcjsPure) import GHCJS.Marshal (ToJSVal(..)) import GHCJS.Marshal.Pure (pToJSVal) -import Data.JSString.Text (textToJSString) #else import Data.Char (chr, ord) import Data.Word (Word, Word8, Word16, Word32) import Data.Int (Int8, Int16, Int32) import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..)) import Language.Javascript.JSaddle.Types - (Object(..), JSString(..), JSVal(..), JSValueForSend(..)) + (Object(..), JSString(..), JSVal(..), ghcjsPure) import Language.Javascript.JSaddle.Native - (wrapJSString, withJSVal, withObject, withJSString, withToJSVal) -import Language.Javascript.JSaddle.Run - (Command(..), AsyncCommand(..), Result(..), sendCommand, - sendLazyCommand) + (valueToNumber, valueToString, valueToJSON, numberToValue, stringToValue, jsonValueToValue) +import qualified Language.Javascript.JSaddle.Native as N + (deRefVal, strictEqual, instanceOf) +import Language.Javascript.JSaddle.Run (Result(..)) #endif import Language.Javascript.JSaddle.Monad (JSM) import Language.Javascript.JSaddle.Classes (MakeObject(..), MakeArgs(..)) import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..)) import Language.Javascript.JSaddle.String (strToText, textToStr) -import Language.Javascript.JSaddle.Foreign (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthyIO, isNullIO, isUndefinedIO) +import GHCJS.Foreign.Internal (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthy, isNull, isUndefined) -- $setup -- >>> import Language.Javascript.JSaddle.Test (testJSaddle) @@ -166,7 +166,7 @@ -- >>> testJSaddle $ valToBool "1" -- true valToBool :: ToJSVal value => value -> JSM Bool -valToBool value = toJSVal value >>= isTruthyIO +valToBool value = toJSVal value >>= ghcjsPure . isTruthy -- | Given a JavaScript value get its numeric value. -- May throw JSException. @@ -192,10 +192,7 @@ valToNumber value = jsrefToNumber <$> toJSVal value foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double #else -valToNumber value = - withToJSVal value $ \rval -> do - ValueToNumberResult result <- sendCommand (ValueToNumber rval) - return result +valToNumber value = toJSVal value >>= valueToNumber #endif -- | Given a JavaScript value get its string value (as a JavaScript string). @@ -222,10 +219,7 @@ valToStr value = jsrefToString <$> toJSVal value foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString #else -valToStr value = - withToJSVal value $ \rval -> do - ValueToStringResult result <- sendCommand (ValueToString rval) - wrapJSString result +valToStr value = toJSVal value >>= valueToString #endif -- | Given a JavaScript value get its string value (as a Haskell 'Text'). @@ -276,10 +270,7 @@ valToJSON value = jsrefToJSON <$> toJSVal value foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString #else -valToJSON value = - withToJSVal value $ \rval -> do - ValueToJSONResult result <- sendCommand (ValueToJSON rval) - wrapJSString result +valToJSON value = toJSVal value >>= valueToJSON #endif -- | Given a JavaScript value get its object value. @@ -305,7 +296,7 @@ valToObject value = Object <$> toJSVal value instance MakeObject JSVal where - makeObject = valToObject + makeObject = return . Object instance ToJSVal Object where toJSVal (Object r) = return r @@ -356,16 +347,16 @@ {-# INLINE toJSVal #-} instance FromJSVal a => FromJSVal (Maybe a) where fromJSValUnchecked x = - isUndefinedIO x >>= \case + ghcjsPure (isUndefined x) >>= \case True -> return Nothing - False -> isNullIO x >>= \case + False -> ghcjsPure (isNull x) >>= \case True -> return Nothing False -> fromJSVal x {-# INLINE fromJSValUnchecked #-} fromJSVal x = - isUndefinedIO x >>= \case + ghcjsPure (isUndefined x) >>= \case True -> return (Just Nothing) - False -> isNullIO x >>= \case + False -> ghcjsPure (isNull x) >>= \case True -> return (Just Nothing) False -> fmap (fmap Just) fromJSVal x {-# INLINE fromJSVal #-} @@ -382,7 +373,7 @@ -- | Test a JavaScript value to see if it is @null@ valIsNull :: ToJSVal value => value -> JSM Bool -valIsNull value = toJSVal value >>= isNullIO +valIsNull value = toJSVal value >>= ghcjsPure . isNull ----------- undefined --------------- -- | An @undefined@ JavaScript value @@ -405,26 +396,26 @@ -- | Test a JavaScript value to see if it is @undefined@ valIsUndefined :: ToJSVal value => value -> JSM Bool -valIsUndefined value = toJSVal value >>= isUndefinedIO +valIsUndefined value = toJSVal value >>= ghcjsPure . isUndefined -- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing) maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal) maybeNullOrUndefined value = do rval <- toJSVal value - valIsNull rval >>= \case + ghcjsPure (isNull rval) >>= \case True -> return Nothing _ -> - valIsUndefined rval >>= \case + ghcjsPure (isUndefined rval) >>= \case True -> return Nothing _ -> return (Just rval) maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a) maybeNullOrUndefined' f value = do rval <- toJSVal value - valIsNull rval >>= \case + ghcjsPure (isNull rval) >>= \case True -> return Nothing _ -> - valIsUndefined rval >>= \case + ghcjsPure (isUndefined rval) >>= \case True -> return Nothing _ -> Just <$> f rval @@ -448,52 +439,49 @@ ----------- numbers --------------- -- | Make a JavaScript number valMakeNumber :: Double -> JSM JSVal -#ifdef ghcjs_HOST_OS -valMakeNumber n = toJSVal n -#else -valMakeNumber = sendLazyCommand . NumberToValue -#endif +valMakeNumber = toJSVal +{-# INLINE valMakeNumber #-} #ifndef ghcjs_HOST_OS -- | Makes a JavaScript number instance ToJSVal Double where - toJSVal = valMakeNumber + toJSVal = numberToValue {-# INLINE toJSVal #-} instance ToJSVal Float where - toJSVal = valMakeNumber . realToFrac + toJSVal = numberToValue . realToFrac {-# INLINE toJSVal #-} instance ToJSVal Word where - toJSVal = valMakeNumber . fromIntegral + toJSVal = numberToValue . fromIntegral {-# INLINE toJSVal #-} instance ToJSVal Word8 where - toJSVal = valMakeNumber . fromIntegral + toJSVal = numberToValue . fromIntegral {-# INLINE toJSVal #-} instance ToJSVal Word16 where - toJSVal = valMakeNumber . fromIntegral + toJSVal = numberToValue . fromIntegral {-# INLINE toJSVal #-} instance ToJSVal Word32 where - toJSVal = valMakeNumber . fromIntegral + toJSVal = numberToValue . fromIntegral {-# INLINE toJSVal #-} instance ToJSVal Int where - toJSVal = valMakeNumber . fromIntegral + toJSVal = numberToValue . fromIntegral {-# INLINE toJSVal #-} instance ToJSVal Int8 where - toJSVal = valMakeNumber . fromIntegral + toJSVal = numberToValue . fromIntegral {-# INLINE toJSVal #-} instance ToJSVal Int16 where - toJSVal = valMakeNumber . fromIntegral + toJSVal = numberToValue . fromIntegral {-# INLINE toJSVal #-} instance ToJSVal Int32 where - toJSVal = valMakeNumber . fromIntegral + toJSVal = numberToValue . fromIntegral {-# INLINE toJSVal #-} #endif @@ -503,25 +491,18 @@ -- | Make a JavaScript string from `Text` valMakeText :: Text -> JSM JSVal -#ifdef ghcjs_HOST_OS -valMakeText = return . pToJSVal . textToJSString -#else -valMakeText text = valMakeString (textToStr text) -#endif +valMakeText = toJSVal . textToJSString +{-# INLINE valMakeText #-} -- | Make a JavaScript string from `JSString` valMakeString :: JSString -> JSM JSVal -#ifdef ghcjs_HOST_OS -valMakeString = return . pToJSVal -#else -valMakeString s = - withJSString s $ sendLazyCommand . StringToValue -#endif +valMakeString = toJSVal +{-# INLINE valMakeString #-} #ifndef ghcjs_HOST_OS -- | Makes a JavaScript string instance ToJSVal Text where - toJSVal = valMakeText + toJSVal = stringToValue . JSString {-# INLINE toJSVal #-} instance FromJSVal Text where fromJSValUnchecked = valToText @@ -537,7 +518,7 @@ #ifndef ghcjs_HOST_OS -- | Makes a JavaScript string instance ToJSVal JSString where - toJSVal = valMakeString + toJSVal = stringToValue {-# INLINE toJSVal #-} instance FromJSVal JSString where fromJSValUnchecked = valToStr @@ -584,16 +565,12 @@ -- | Make a JavaScript string from AESON `Value` valMakeJSON :: Value -> JSM JSVal -#ifdef ghcjs_HOST_OS valMakeJSON = toJSVal -#else -valMakeJSON = sendLazyCommand . JSONValueToValue -#endif #ifndef ghcjs_HOST_OS -- | Makes a JSON value instance ToJSVal Value where - toJSVal = valMakeJSON + toJSVal = jsonValueToValue {-# INLINE toJSVal #-} #endif @@ -642,18 +619,16 @@ (typeof $1===\"string\")?4:\ (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int #else -deRefVal value = do - v <- toJSVal value - withJSVal v $ \rval -> - sendCommand (DeRefVal rval) >>= \case - DeRefValResult 0 _ -> return ValNull - DeRefValResult 1 _ -> return ValUndefined - DeRefValResult 2 _ -> return $ ValBool False - DeRefValResult 3 _ -> return $ ValBool True - DeRefValResult (-1) s -> return $ ValNumber (read (T.unpack s)) - DeRefValResult (-2) s -> return $ ValString s - DeRefValResult ref _ -> return $ ValObject (Object (JSVal ref)) - _ -> error "Unexpected result dereferencing JSaddle value" +deRefVal value = toJSVal value >>= N.deRefVal >>= \result -> return $ + case result of + DeRefValResult 0 _ -> ValNull + DeRefValResult 1 _ -> ValUndefined + DeRefValResult 2 _ -> ValBool False + DeRefValResult 3 _ -> ValBool True + DeRefValResult (-1) s -> ValNumber (read (T.unpack s)) + DeRefValResult (-2) s -> ValString s + DeRefValResult ref _ -> ValObject (Object (JSVal ref)) + _ -> error "Unexpected result dereferencing JSaddle value" #endif -- | Make a JavaScript value out of a 'JSValue' ADT. @@ -712,10 +687,7 @@ #ifdef ghcjs_HOST_OS return $ jsvalueisstrictequal aval bval #else - withJSVal aval $ \aref -> - withJSVal bval $ \bref -> do - StrictEqualResult result <- sendCommand $ StrictEqual aref bref - return result + N.strictEqual aval bval #endif #ifdef ghcjs_HOST_OS @@ -733,10 +705,7 @@ #ifdef ghcjs_HOST_OS return $ js_isInstanceOf v c #else - withJSVal v $ \rval -> - withObject c $ \c' -> do - InstanceOfResult result <- sendCommand $ InstanceOf rval c' - return result + N.instanceOf v c #endif