on master help sign in
Improved ghcjs-base and ghcvjs-prim compatibility
5378295Hamish Mackenzie
jsaddle/jsaddle.cabal+29−3
@@ -1,5 +1,5 @@
1name: jsaddle
1name: jsaddle
2−version: 0.7.1.0
2+version: 0.8.0.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -40,23 +40,48 @@ library
40 unordered-containers >=0.2 && <0.3,
40 unordered-containers >=0.2 && <0.3,
41 vector >=0.10 && <0.12
41 vector >=0.10 && <0.12
42 exposed-modules:
42 exposed-modules:
43+ Data.JSString
44+ Data.JSString.Internal
45+ Data.JSString.Internal.Fusion
46+ Data.JSString.Internal.Fusion.CaseMapping
47+ Data.JSString.Internal.Fusion.Common
48+ Data.JSString.Internal.Fusion.Types
49+ Data.JSString.Internal.Search
50+ Data.JSString.Internal.Type
51+ Data.JSString.Text
52+ GHCJS.Prim
53+ GHCJS.Prim.Internal
54+ GHCJS.Types
55+ GHCJS.Foreign
56+ GHCJS.Foreign.Internal
57+ GHCJS.Internal.Types
43 GHCJS.Marshal
58 GHCJS.Marshal
44 GHCJS.Marshal.Internal
59 GHCJS.Marshal.Internal
45 GHCJS.Marshal.Pure
60 GHCJS.Marshal.Pure
61+ GHCJS.Buffer
62+ GHCJS.Buffer.Types
63+ JavaScript.TypedArray
64+ JavaScript.TypedArray.ArrayBuffer
65+ JavaScript.TypedArray.ArrayBuffer.Internal
66+ JavaScript.TypedArray.ArrayBuffer.Type
67+ JavaScript.TypedArray.DataView.Internal
68+ JavaScript.TypedArray.Immutable
69+ JavaScript.TypedArray.Internal
70+ JavaScript.TypedArray.Internal.Types
71+ JavaScript.Array
46 JavaScript.Array.Internal
72 JavaScript.Array.Internal
73+ JavaScript.Object
47 JavaScript.Object.Internal
74 JavaScript.Object.Internal
48 Language.Javascript.JSaddle.Native
75 Language.Javascript.JSaddle.Native
49 Language.Javascript.JSaddle.Native.Internal
76 Language.Javascript.JSaddle.Native.Internal
50 hs-source-dirs: src-ghc
77 hs-source-dirs: src-ghc
51 exposed-modules:
78 exposed-modules:
52 Language.Javascript.JSaddle
79 Language.Javascript.JSaddle
53− Language.Javascript.JSaddle.Array
54 Language.Javascript.JSaddle.Arguments
80 Language.Javascript.JSaddle.Arguments
55 Language.Javascript.JSaddle.Classes
81 Language.Javascript.JSaddle.Classes
56 Language.Javascript.JSaddle.Classes.Internal
82 Language.Javascript.JSaddle.Classes.Internal
57 Language.Javascript.JSaddle.Evaluate
83 Language.Javascript.JSaddle.Evaluate
58 Language.Javascript.JSaddle.Exception
84 Language.Javascript.JSaddle.Exception
59− Language.Javascript.JSaddle.Foreign
60 Language.Javascript.JSaddle.Marshal.String
85 Language.Javascript.JSaddle.Marshal.String
61 Language.Javascript.JSaddle.Monad
86 Language.Javascript.JSaddle.Monad
62 Language.Javascript.JSaddle.Object
87 Language.Javascript.JSaddle.Object
@@ -69,6 +94,7 @@ library
69 build-depends:
94 build-depends:
70 aeson >=0.8.0.2 && <1.1,
95 aeson >=0.8.0.2 && <1.1,
71 base <5,
96 base <5,
97+ base64-bytestring >=1.0.0.1 && <1.1,
72 bytestring >=0.10.6.0 && <0.11,
98 bytestring >=0.10.6.0 && <0.11,
73 lens >=3.8.5 && <4.16,
99 lens >=3.8.5 && <4.16,
74 primitive >=0.6.1.0 && <0.7,
100 primitive >=0.6.1.0 && <0.7,
jsaddle/src-ghc/Data/JSString.hsnew file+1403
@@ -0,0 +1,1403 @@
1+{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies
2+ #-}
3+{-| Manipulation of JavaScript strings, API and fusion implementation
4+ based on Data.Text by Tom Harper, Duncan Coutts, Bryan O'Sullivan e.a.
5+ -}
6+module Data.JSString ( JSString
7+
8+ -- * Creation and elimination
9+ , pack
10+ , unpack, unpack'
11+ , singleton
12+ , empty
13+
14+ -- * Basic interface
15+ , cons
16+ , snoc
17+ , append
18+ , uncons
19+ , head
20+ , last
21+ , tail
22+ , init
23+ , null
24+ , length
25+ , compareLength
26+
27+ -- * Transformations
28+ , map
29+ , intercalate
30+ , intersperse
31+ , transpose
32+ , reverse
33+ , replace
34+
35+ -- ** Case conversion
36+ , toCaseFold
37+ , toLower
38+ , toUpper
39+ , toTitle
40+
41+ -- ** Justification
42+ , justifyLeft
43+ , justifyRight
44+ , center
45+
46+ -- * Folds
47+ , foldl
48+ , foldl'
49+ , foldl1
50+ , foldl1'
51+ , foldr
52+ , foldr1
53+
54+ -- ** Special folds
55+ , concat
56+ , concatMap
57+ , any
58+ , all
59+ , maximum
60+ , minimum
61+
62+ -- * Construction
63+
64+ -- ** Scans
65+ , scanl
66+ , scanl1
67+ , scanr
68+ , scanr1
69+
70+ -- ** Accumulating maps
71+ , mapAccumL
72+ , mapAccumR
73+
74+ -- ** Generation and unfolding
75+ , replicate
76+ , unfoldr
77+ , unfoldrN
78+
79+ -- * Substrings
80+
81+ -- ** Breaking strings
82+ , take
83+ , takeEnd
84+ , drop
85+ , dropEnd
86+ , takeWhile
87+ , dropWhile
88+ , dropWhileEnd
89+ , dropAround
90+ , strip
91+ , stripStart
92+ , stripEnd
93+ , splitAt
94+ , breakOn
95+ , breakOnEnd
96+ , break
97+ , span
98+ , group
99+ , group'
100+ , groupBy
101+ , inits
102+ , tails
103+
104+ -- ** Breaking into many substrings
105+ , splitOn, splitOn'
106+ , split
107+ , chunksOf, chunksOf'
108+
109+ -- ** Breaking into lines and words
110+ , lines, lines'
111+ , words, words'
112+ , unlines
113+ , unwords
114+
115+ -- * Predicates
116+ , isPrefixOf
117+ , isSuffixOf
118+ , isInfixOf
119+
120+ -- ** View patterns
121+ , stripPrefix
122+ , stripSuffix
123+ , commonPrefixes
124+
125+ -- * Searching
126+ , filter
127+ , breakOnAll, breakOnAll'
128+ , find
129+ , partition
130+
131+ -- * Indexing
132+ , index
133+ , findIndex
134+ , count
135+
136+ -- * Zipping
137+ , zip
138+ , zipWith
139+ ) where
140+
141+import Prelude
142+ ( Char, Bool(..), Int, Maybe(..), String, Eq(..), Ord(..), Ordering(..), (++)
143+ , Read(..), Show(..), (&&), (||), (+), (-), (.), ($), ($!), (>>)
144+ , not, seq, return, otherwise, quot)
145+import qualified Prelude as P
146+
147+import Control.DeepSeq (NFData(..))
148+import Data.Char (isSpace)
149+import Data.Coerce (coerce)
150+import qualified Data.List as L
151+import Data.Data
152+import qualified Data.Text as T
153+import qualified Data.Text.Internal.Fusion as TF
154+import qualified Data.Text.Internal.Fusion.Common as TF
155+
156+import GHC.Exts
157+ ( Int#, (+#), (-#), (>=#), (>#), isTrue#, chr#, Char(..)
158+ , Int(..), Addr#, tagToEnum#)
159+import qualified GHC.Exts as Exts
160+import qualified GHC.CString as GHC
161+
162+import Unsafe.Coerce
163+
164+import GHCJS.Prim (JSVal)
165+
166+import Data.JSString.Internal.Type
167+import Data.JSString.Internal.Fusion (stream, unstream)
168+import qualified Data.JSString.Internal.Fusion as S
169+import qualified Data.JSString.Internal.Fusion.Common as S
170+
171+instance Exts.IsList JSString where
172+ type Item JSString = Char
173+ fromList = pack
174+ toList = unpack
175+
176+-- -----------------------------------------------------------------------------
177+-- * Conversion to/from 'JSString'
178+
179+-- | /O(n)/ Convert a 'String' into a 'JSString'. Subject to
180+-- fusion.
181+pack :: String -> JSString
182+pack = coerce T.pack
183+{-# INLINE [1] pack #-}
184+
185+{-# RULES
186+"JSSTRING pack -> fused" [~1] forall x.
187+ pack x = unstream (S.map safe (S.streamList x))
188+"JSSTRING pack -> unfused" [1] forall x.
189+ unstream (S.map safe (S.streamList x)) = pack x
190+ #-}
191+
192+-- | /O(n)/ Convert a 'JSString' into a 'String'. Subject to fusion.
193+unpack :: JSString -> String
194+unpack = S.unstreamList . stream
195+{-# INLINE [1] unpack #-}
196+
197+unpack' :: JSString -> String
198+unpack' = coerce T.unpack
199+{-# INLINE unpack' #-}
200+
201+-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion.
202+unpackCString# :: Addr# -> JSString
203+unpackCString# = coerce T.unpackCString#
204+{-# NOINLINE unpackCString# #-}
205+
206+{-# RULES "JSSTRING literal" forall a.
207+ unstream (S.map safe (S.streamList (GHC.unpackCString# a)))
208+ = unpackCString# a #-}
209+
210+{-# RULES "JSSTRING literal UTF8" forall a.
211+ unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a)))
212+ = unpackCString# a #-}
213+
214+{-# RULES "JSSTRING empty literal"
215+ unstream (S.map safe (S.streamList []))
216+ = empty_ #-}
217+
218+{-# RULES "JSSTRING singleton literal" forall a.
219+ unstream (S.map safe (S.streamList [a]))
220+ = singleton a #-}
221+
222+
223+-- | /O(1)/ Convert a character into a 'JSString'. Subject to fusion.
224+-- Performs replacement on invalid scalar values.
225+singleton :: Char -> JSString
226+singleton = coerce T.singleton
227+{-# INLINE [1] singleton #-}
228+
229+{-# RULES
230+"JSSTRING singleton -> fused" [~1] forall a.
231+ singleton a = unstream (S.singleton (safe a))
232+"JSSTRING singleton -> unfused" [1] forall a.
233+ unstream (S.singleton (safe a)) = singleton a
234+ #-}
235+
236+-- This is intended to reduce inlining bloat.
237+-- singleton_ :: Char -> Text
238+-- singleton_ c = js_singleton c
239+
240+-- Text (A.run x) 0 len
241+-- where x :: ST s (A.MArray s)
242+-- x = do arr <- A.new len
243+-- _ <- unsafeWrite arr 0 d
244+-- return arr
245+-- len | d < '\x10000' = 1
246+-- x | otherwise = 2
247+-- d = safe c
248+-- {-# NOINLINE singleton_ #-}
249+
250+-- -----------------------------------------------------------------------------
251+-- * Basic functions
252+
253+-- | /O(n)/ Adds a character to the front of a 'JSString'. This function
254+-- is more costly than its 'List' counterpart because it requires
255+-- copying a new array. Subject to fusion. Performs replacement on
256+-- invalid scalar values.
257+cons :: Char -> JSString -> JSString
258+cons = coerce T.cons
259+{-# INLINE [1] cons #-}
260+
261+{-# RULES
262+"JSSTRING cons -> fused" [~1] forall c x.
263+ cons c x = unstream (S.cons (safe c) (stream x))
264+"JSSTRING cons -> unfused" [1] forall c x.
265+ unstream (S.cons (safe c) (stream x)) = cons c x
266+ #-}
267+
268+infixr 5 `cons`
269+
270+-- | /O(n)/ Adds a character to the end of a 'JSString'. This copies the
271+-- entire array in the process, unless fused. Subject to fusion.
272+-- Performs replacement on invalid scalar values.
273+snoc :: JSString -> Char -> JSString
274+snoc = coerce T.snoc
275+ -- unstream (S.snoc (stream t) (safe c))
276+{-# INLINE [1] snoc #-}
277+
278+{-# RULES
279+"JSSTRING snoc -> fused" [~1] forall x c.
280+ snoc x c = unstream (S.snoc (stream x) (safe c))
281+"JSSTRING snoc -> unfused" [1] forall x c.
282+ unstream (S.snoc (stream x) (safe c)) = snoc x c
283+ #-}
284+
285+-- | /O(n)/ Appends one 'JSString' to the other by copying both of them
286+-- into a new 'JSString'. Subject to fusion.
287+append :: JSString -> JSString -> JSString
288+append = coerce T.append
289+{-# INLINE [1] append #-}
290+
291+{-# RULES
292+"JSSTRING append -> fused" [~1] forall x1 x2.
293+ append x1 x2 = unstream (S.append (stream x1) (stream x2))
294+"JSSTRING append -> unfused" [1] forall x1 x2.
295+ unstream (S.append (stream x1) (stream x2)) = append x1 x2
296+ #-}
297+
298+-- | /O(1)/ Returns the first character of a 'JSString', which must be
299+-- non-empty. Subject to fusion.
300+head :: JSString -> Char
301+head = coerce T.head
302+{-# INLINE [1] head #-}
303+
304+{-# RULES
305+"JSSTRING head -> fused" [~1] forall x.
306+ head x = S.head (stream x)
307+"JSSTRING head -> unfused" [1] forall x.
308+ S.head (stream x) = head x
309+ #-}
310+
311+
312+-- | /O(1)/ Returns the first character and rest of a 'JSString', or
313+-- 'Nothing' if empty. Subject to fusion.
314+uncons :: JSString -> Maybe (Char, JSString)
315+uncons = coerce T.uncons
316+{-# INLINE [1] uncons #-}
317+
318+-- | Lifted from Control.Arrow and specialized.
319+second :: (b -> c) -> (a,b) -> (a,c)
320+second f (a, b) = (a, f b)
321+
322+-- | /O(1)/ Returns the last character of a 'JSString', which must be
323+-- non-empty. Subject to fusion.
324+last :: JSString -> Char
325+last = coerce T.last
326+{-# INLINE [1] last #-}
327+
328+{-# RULES
329+"JSSTRING last -> fused" [~1] forall x.
330+ last x = S.last (stream x)
331+"JSSTRING last -> unfused" [1] forall x.
332+ S.last (stream x) = last x
333+ #-}
334+
335+-- | /O(1)/ Returns all characters after the head of a 'JSString', which
336+-- must be non-empty. Subject to fusion.
337+tail :: JSString -> JSString
338+tail = coerce T.tail
339+{-# INLINE [1] tail #-}
340+
341+{-# RULES
342+"JSSTRING tail -> fused" [~1] forall x.
343+ tail x = unstream (S.tail (stream x))
344+"JSSTRING tail -> unfused" [1] forall x.
345+ unstream (S.tail (stream x)) = tail x
346+ #-}
347+
348+-- | /O(1)/ Returns all but the last character of a 'JSString', which must
349+-- be non-empty. Subject to fusion.
350+init :: JSString -> JSString
351+init = coerce T.init
352+{-# INLINE [1] init #-}
353+
354+{-# RULES
355+"JSSTRING init -> fused" [~1] forall t.
356+ init t = unstream (S.init (stream t))
357+"JSSTRING init -> unfused" [1] forall t.
358+ unstream (S.init (stream t)) = init t
359+ #-}
360+
361+-- | /O(1)/ Tests whether a 'JSString' is empty or not. Subject to
362+-- fusion.
363+null :: JSString -> Bool
364+null = coerce T.null
365+{-# INLINE [1] null #-}
366+
367+{-# RULES
368+"JSSTRING null -> fused" [~1] forall t.
369+ null t = S.null (stream t)
370+"JSSTRING null -> unfused" [1] forall t.
371+ S.null (stream t) = null t
372+ #-}
373+
374+-- | /O(n)/ Returns the number of characters in a 'JSString'.
375+-- Subject to fusion.
376+length :: JSString -> Int
377+length = coerce T.length
378+{-# INLINE [1] length #-}
379+
380+{-# RULES
381+"JSSTRING length -> fused" [~1] forall x.
382+ length x = S.length (stream x)
383+"JSSTRING length -> unfused" [1] forall x.
384+ S.length (stream x) = length x
385+ #-}
386+
387+-- | /O(n)/ Compare the count of characters in a 'JSString' to a number.
388+-- Subject to fusion.
389+--
390+-- This function gives the same answer as comparing against the result
391+-- of 'length', but can short circuit if the count of characters is
392+-- greater than the number, and hence be more efficient.
393+compareLength :: JSString -> Int -> Ordering
394+compareLength = coerce T.compareLength
395+{-# INLINE [1] compareLength #-}
396+
397+{-# RULES
398+"JSSTRING compareN/length -> compareLength" [~1] forall t n.
399+ compare (length t) n = compareLength t n
400+ #-}
401+
402+{-# RULES
403+"JSSTRING ==N/length -> compareLength/==EQ" [~1] forall t n.
404+ (==) (length t) n = compareLength t n == EQ
405+ #-}
406+
407+{-# RULES
408+"JSSTRING /=N/length -> compareLength//=EQ" [~1] forall t n.
409+ (/=) (length t) n = compareLength t n /= EQ
410+ #-}
411+
412+{-# RULES
413+"JSSTRING <N/length -> compareLength/==LT" [~1] forall t n.
414+ (<) (length t) n = compareLength t n == LT
415+ #-}
416+
417+{-# RULES
418+"JSSTRING <=N/length -> compareLength//=GT" [~1] forall t n.
419+ (<=) (length t) n = compareLength t n /= GT
420+ #-}
421+
422+{-# RULES
423+"JSSTRING >N/length -> compareLength/==GT" [~1] forall t n.
424+ (>) (length t) n = compareLength t n == GT
425+ #-}
426+
427+{-# RULES
428+"JSSTRING >=N/length -> compareLength//=LT" [~1] forall t n.
429+ (>=) (length t) n = compareLength t n /= LT
430+ #-}
431+
432+-- -----------------------------------------------------------------------------
433+-- * Transformations
434+-- | /O(n)/ 'map' @f@ @t@ is the 'JSString' obtained by applying @f@ to
435+-- each element of @t@. Subject to fusion. Performs replacement on
436+-- invalid scalar values.
437+map :: (Char -> Char) -> JSString -> JSString
438+map = coerce T.map
439+{-# INLINE [1] map #-}
440+
441+-- | /O(n)/ The 'intercalate' function takes a 'JSString' and a list of
442+-- 'JSString's and concatenates the list after interspersing the first
443+-- argument between each element of the list.
444+intercalate :: JSString -> [JSString] -> JSString
445+intercalate = coerce T.intercalate
446+{-# INLINE [1] intercalate #-}
447+
448+-- | /O(n)/ The 'intersperse' function takes a character and places it
449+-- between the characters of a 'JSString'. Subject to fusion. Performs
450+-- replacement on invalid scalar values.
451+intersperse :: Char -> JSString -> JSString
452+intersperse = coerce T.intersperse
453+{-# INLINE [1] intersperse #-}
454+
455+{-# RULES
456+"JSSTRING intersperse -> fused" [~1] forall c x.
457+ intersperse c x = unstream (S.intersperse (safe c) (stream x))
458+"JSSTRING intersperse -> unfused" [1] forall c x.
459+ unstream (S.intersperse (safe c) (stream x)) = intersperse c x
460+ #-}
461+
462+-- | /O(n)/ Reverse the characters of a string. Subject to fusion.
463+reverse :: JSString -> JSString
464+reverse = coerce T.reverse
465+{-# INLINE [1] reverse #-}
466+
467+{-# RULES
468+"JSSTRING reverse -> fused" [~1] forall x.
469+ reverse x = S.reverse (stream x)
470+"JSSTRING reverse -> unfused" [1] forall x.
471+ S.reverse (stream x) = reverse x
472+ #-}
473+
474+-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
475+-- @haystack@ with @replacement@.
476+--
477+-- This function behaves as though it was defined as follows:
478+--
479+-- @
480+-- replace needle replacement haystack =
481+-- 'intercalate' replacement ('splitOn' needle haystack)
482+-- @
483+--
484+-- As this suggests, each occurrence is replaced exactly once. So if
485+-- @needle@ occurs in @replacement@, that occurrence will /not/ itself
486+-- be replaced recursively:
487+--
488+-- > replace "oo" "foo" "oo" == "foo"
489+--
490+-- In cases where several instances of @needle@ overlap, only the
491+-- first one will be replaced:
492+--
493+-- > replace "ofo" "bar" "ofofo" == "barfo"
494+--
495+-- In (unlikely) bad cases, this function's time complexity degrades
496+-- towards /O(n*m)/.
497+replace :: JSString
498+ -- ^ @needle@ to search for. If this string is empty, an
499+ -- error will occur.
500+ -> JSString
501+ -- ^ @replacement@ to replace @needle@ with.
502+ -> JSString
503+ -- ^ @haystack@ in which to search.
504+ -> JSString
505+replace = coerce T.replace
506+{-# INLINE replace #-}
507+
508+-- ----------------------------------------------------------------------------
509+-- ** Case conversions (folds)
510+
511+-- $case
512+--
513+-- When case converting 'JSString' values, do not use combinators like
514+-- @map toUpper@ to case convert each character of a string
515+-- individually, as this gives incorrect results according to the
516+-- rules of some writing systems. The whole-string case conversion
517+-- functions from this module, such as @toUpper@, obey the correct
518+-- case conversion rules. As a result, these functions may map one
519+-- input character to two or three output characters. For examples,
520+-- see the documentation of each function.
521+--
522+-- /Note/: In some languages, case conversion is a locale- and
523+-- context-dependent operation. The case conversion functions in this
524+-- module are /not/ locale sensitive. Programs that require locale
525+-- sensitivity should use appropriate versions of the
526+-- <http://hackage.haskell.org/package/text-icu-0.6.3.7/docs/Data-Text-ICU.html#g:4 case mapping functions from the text-icu package >.
527+
528+-- | /O(n)/ Convert a string to folded case. Subject to fusion.
529+--
530+-- This function is mainly useful for performing caseless (also known
531+-- as case insensitive) string comparisons.
532+--
533+-- A string @x@ is a caseless match for a string @y@ if and only if:
534+--
535+-- @toCaseFold x == toCaseFold y@
536+--
537+-- The result string may be longer than the input string, and may
538+-- differ from applying 'toLower' to the input string. For instance,
539+-- the Armenian small ligature \"&#xfb13;\" (men now, U+FB13) is case
540+-- folded to the sequence \"&#x574;\" (men, U+0574) followed by
541+-- \"&#x576;\" (now, U+0576), while the Greek \"&#xb5;\" (micro sign,
542+-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)
543+-- instead of itself.
544+toCaseFold :: JSString -> JSString
545+toCaseFold = coerce T.toCaseFold
546+{-# INLINE [0] toCaseFold #-}
547+
548+-- | /O(n)/ Convert a string to lower case, using simple case
549+-- conversion. Subject to fusion.
550+--
551+-- The result string may be longer than the input string. For
552+-- instance, \"&#x130;\" (Latin capital letter I with dot above,
553+-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
554+-- followed by \" &#x307;\" (combining dot above, U+0307).
555+toLower :: JSString -> JSString
556+toLower = coerce T.toLower
557+{-# INLINE [1] toLower #-}
558+
559+{-# RULES
560+"JSSTRING toLower -> fused" [~1] forall x.
561+ toLower x = unstream (S.toLower (stream x))
562+"JSSTRING toLower -> unfused" [1] forall x.
563+ unstream (S.toLower (stream x)) = toLower x
564+ #-}
565+
566+-- | /O(n)/ Convert a string to upper case, using simple case
567+-- conversion. Subject to fusion.
568+--
569+-- The result string may be longer than the input string. For
570+-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
571+-- two-letter sequence \"SS\".
572+toUpper :: JSString -> JSString
573+toUpper = coerce T.toUpper
574+{-# INLINE [1] toUpper #-}
575+
576+{-# RULES
577+"JSSTRING toUpper -> fused" [~1] forall x.
578+ toUpper x = unstream (S.toUpper(stream x))
579+"JSSTRING toUpper -> unfused" [1] forall x.
580+ unstream (S.toUpper (stream x)) = toUpper x
581+ #-}
582+
583+-- | /O(n)/ Convert a string to title case, using simple case
584+-- conversion. Subject to fusion.
585+--
586+-- The first letter of the input is converted to title case, as is
587+-- every subsequent letter that immediately follows a non-letter.
588+-- Every letter that immediately follows another letter is converted
589+-- to lower case.
590+--
591+-- The result string may be longer than the input string. For example,
592+-- the Latin small ligature &#xfb02; (U+FB02) is converted to the
593+-- sequence Latin capital letter F (U+0046) followed by Latin small
594+-- letter l (U+006C).
595+--
596+-- /Note/: this function does not take language or culture specific
597+-- rules into account. For instance, in English, different style
598+-- guides disagree on whether the book name \"The Hill of the Red
599+-- Fox\" is correctly title cased&#x2014;but this function will
600+-- capitalize /every/ word.
601+toTitle :: JSString -> JSString
602+toTitle = coerce T.toTitle
603+{-# INLINE toTitle #-}
604+
605+-- | /O(n)/ Left-justify a string to the given length, using the
606+-- specified fill character on the right. Subject to fusion.
607+-- Performs replacement on invalid scalar values.
608+--
609+-- Examples:
610+--
611+-- > justifyLeft 7 'x' "foo" == "fooxxxx"
612+-- > justifyLeft 3 'x' "foobar" == "foobar"
613+justifyLeft :: Int -> Char -> JSString -> JSString
614+justifyLeft = coerce T.justifyLeft
615+{-# INLINE [1] justifyLeft #-}
616+
617+{-# RULES
618+"JSSTRING justifyLeft -> fused" [~1] forall k c t.
619+ justifyLeft k c t = unstream (S.justifyLeftI k c (stream t))
620+"JSSTRING justifyLeft -> unfused" [1] forall k c t.
621+ unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t
622+ #-}
623+
624+-- | /O(n)/ Right-justify a string to the given length, using the
625+-- specified fill character on the left. Performs replacement on
626+-- invalid scalar values.
627+--
628+-- Examples:
629+--
630+-- > justifyRight 7 'x' "bar" == "xxxxbar"
631+-- > justifyRight 3 'x' "foobar" == "foobar"
632+justifyRight :: Int -> Char -> JSString -> JSString
633+justifyRight = coerce T.justifyRight
634+{-# INLINE justifyRight #-}
635+
636+-- | /O(n)/ Center a string to the given length, using the specified
637+-- fill character on either side. Performs replacement on invalid
638+-- scalar values.
639+--
640+-- Examples:
641+--
642+-- > center 8 'x' "HS" = "xxxHSxxx"
643+center :: Int -> Char -> JSString -> JSString
644+center = coerce T.center
645+{-# INLINE center #-}
646+
647+-- | /O(n)/ The 'transpose' function transposes the rows and columns
648+-- of its 'JSString' argument. Note that this function uses 'pack',
649+-- 'unpack', and the list version of transpose, and is thus not very
650+-- efficient.
651+transpose :: [JSString] -> [JSString]
652+transpose = coerce T.transpose
653+
654+-- -----------------------------------------------------------------------------
655+-- * Reducing 'JSString's (folds)
656+
657+-- | /O(n)/ 'foldl', applied to a binary operator, a starting value
658+-- (typically the left-identity of the operator), and a 'JSString',
659+-- reduces the 'JSString' using the binary operator, from left to right.
660+-- Subject to fusion.
661+foldl :: (a -> Char -> a) -> a -> JSString -> a
662+foldl f = coerce (T.foldl f)
663+{-# INLINE foldl #-}
664+
665+-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.
666+foldl' :: (a -> Char -> a) -> a -> JSString -> a
667+foldl' f = coerce (T.foldl' f)
668+{-# INLINE foldl' #-}
669+
670+-- | /O(n)/ A variant of 'foldl' that has no starting value argument,
671+-- and thus must be applied to a non-empty 'JSString'. Subject to fusion.
672+foldl1 :: (Char -> Char -> Char) -> JSString -> Char
673+foldl1 = coerce T.foldl1
674+{-# INLINE foldl1 #-}
675+
676+-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.
677+foldl1' :: (Char -> Char -> Char) -> JSString -> Char
678+foldl1' = coerce T.foldl1'
679+{-# INLINE foldl1' #-}
680+
681+-- | /O(n)/ 'foldr', applied to a binary operator, a starting value
682+-- (typically the right-identity of the operator), and a 'JSString',
683+-- reduces the 'JSString' using the binary operator, from right to left.
684+-- Subject to fusion.
685+foldr :: (Char -> a -> a) -> a -> JSString -> a
686+foldr f = coerce (T.foldr f)
687+{-# INLINE foldr #-}
688+
689+-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
690+-- and thus must be applied to a non-empty 'JSString'. Subject to
691+-- fusion.
692+foldr1 :: (Char -> Char -> Char) -> JSString -> Char
693+foldr1 = coerce T.foldr1
694+{-# INLINE foldr1 #-}
695+
696+-- -----------------------------------------------------------------------------
697+-- ** Special folds
698+
699+-- | /O(n)/ Concatenate a list of 'JSString's.
700+concat :: [JSString] -> JSString
701+concat = coerce T.concat
702+
703+-- | /O(n)/ Map a function over a 'JSString' that results in a 'JSString', and
704+-- concatenate the results.
705+concatMap :: (Char -> JSString) -> JSString -> JSString
706+concatMap = coerce T.concatMap
707+{-# INLINE concatMap #-}
708+
709+-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
710+-- 'JSString' @t@ satisifes the predicate @p@. Subject to fusion.
711+any :: (Char -> Bool) -> JSString -> Bool
712+any = coerce T.any
713+{-# INLINE any #-}
714+
715+-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
716+-- 'JSString' @t@ satisify the predicate @p@. Subject to fusion.
717+all :: (Char -> Bool) -> JSString -> Bool
718+all = coerce T.all
719+{-# INLINE all #-}
720+
721+-- | /O(n)/ 'maximum' returns the maximum value from a 'JSString', which
722+-- must be non-empty. Subject to fusion.
723+maximum :: JSString -> Char
724+maximum = coerce T.maximum
725+{-# INLINE maximum #-}
726+
727+-- | /O(n)/ 'minimum' returns the minimum value from a 'JSString', which
728+-- must be non-empty. Subject to fusion.
729+minimum :: JSString -> Char
730+minimum = coerce T.minimum
731+{-# INLINE minimum #-}
732+
733+-- -----------------------------------------------------------------------------
734+-- * Building 'JSString's
735+
736+-- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of
737+-- successive reduced values from the left. Subject to fusion.
738+-- Performs replacement on invalid scalar values.
739+--
740+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
741+--
742+-- Note that
743+--
744+-- > last (scanl f z xs) == foldl f z xs.
745+scanl :: (Char -> Char -> Char) -> Char -> JSString -> JSString
746+scanl = coerce T.scanl
747+{-# INLINE scanl #-}
748+
749+-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting
750+-- value argument. Subject to fusion. Performs replacement on
751+-- invalid scalar values.
752+--
753+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
754+scanl1 :: (Char -> Char -> Char) -> JSString -> JSString
755+scanl1 = coerce T.scanl1
756+{-# INLINE scanl1 #-}
757+
758+-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs
759+-- replacement on invalid scalar values.
760+--
761+-- > scanr f v == reverse . scanl (flip f) v . reverse
762+scanr :: (Char -> Char -> Char) -> Char -> JSString -> JSString
763+scanr = coerce T.scanr
764+{-# INLINE scanr #-}
765+
766+-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting
767+-- value argument. Subject to fusion. Performs replacement on
768+-- invalid scalar values.
769+scanr1 :: (Char -> Char -> Char) -> JSString -> JSString
770+scanr1 = coerce T.scanr1
771+{-# INLINE scanr1 #-}
772+
773+-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
774+-- function to each element of a 'JSString', passing an accumulating
775+-- parameter from left to right, and returns a final 'JSString'. Performs
776+-- replacement on invalid scalar values.
777+mapAccumL :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)
778+mapAccumL f = coerce (T.mapAccumL f)
779+{-# INLINE mapAccumL #-}
780+
781+-- | The 'mapAccumR' function behaves like a combination of 'map' and
782+-- a strict 'foldr'; it applies a function to each element of a
783+-- 'JSString', passing an accumulating parameter from right to left, and
784+-- returning a final value of this accumulator together with the new
785+-- 'JSString'.
786+-- Performs replacement on invalid scalar values.
787+mapAccumR :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)
788+mapAccumR f = coerce (T.mapAccumR f)
789+{-# INLINE mapAccumR #-}
790+
791+-- -----------------------------------------------------------------------------
792+-- ** Generating and unfolding 'JSString's
793+
794+-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'JSString' consisting of the input
795+-- @t@ repeated @n@ times.
796+replicate :: Int -> JSString -> JSString
797+replicate = coerce T.replicate
798+{-# INLINE [1] replicate #-}
799+
800+-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'
801+-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a
802+-- 'JSString' from a seed value. The function takes the element and
803+-- returns 'Nothing' if it is done producing the 'JSString', otherwise
804+-- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the
805+-- string, and @b@ is the seed value for further production. Subject
806+-- to fusion. Performs replacement on invalid scalar values.
807+unfoldr :: (a -> Maybe (Char,a)) -> a -> JSString
808+unfoldr f = coerce (T.unfoldr f)
809+{-# INLINE unfoldr #-}
810+
811+-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'JSString' from a seed
812+-- value. However, the length of the result should be limited by the
813+-- first argument to 'unfoldrN'. This function is more efficient than
814+-- 'unfoldr' when the maximum length of the result is known and
815+-- correct, otherwise its performance is similar to 'unfoldr'. Subject
816+-- to fusion. Performs replacement on invalid scalar values.
817+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> JSString
818+unfoldrN n f = coerce (T.unfoldrN n f)
819+{-# INLINE unfoldrN #-}
820+
821+-- -----------------------------------------------------------------------------
822+-- * Substrings
823+
824+-- | /O(n)/ 'take' @n@, applied to a 'JSString', returns the prefix of the
825+-- 'JSString' of length @n@, or the 'JSString' itself if @n@ is greater than
826+-- the length of the JSString. Subject to fusion.
827+take :: Int -> JSString -> JSString
828+take = coerce T.take
829+{-# INLINE [1] take #-}
830+{-
831+iterN :: Int -> JSString -> Int
832+iterN n t@(Text _arr _off len) = loop 0 0
833+ where loop !i !cnt
834+ | i >= len || cnt >= n = i
835+ | otherwise = loop (i+d) (cnt+1)
836+ where d = iter_ t i
837+-}
838+{-# RULES
839+"JSSTRING take -> fused" [~1] forall n t.
840+ take n t = unstream (S.take n (stream t))
841+"JSSTRING take -> unfused" [1] forall n t.
842+ unstream (S.take n (stream t)) = take n t
843+ #-}
844+
845+-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after
846+-- taking @n@ characters from the end of @t@.
847+--
848+-- Examples:
849+--
850+-- > takeEnd 3 "foobar" == "bar"
851+takeEnd :: Int -> JSString -> JSString
852+takeEnd = coerce T.takeEnd
853+
854+-- | /O(n)/ 'drop' @n@, applied to a 'JSString', returns the suffix of the
855+-- 'JSString' after the first @n@ characters, or the empty 'JSString' if @n@
856+-- is greater than the length of the 'JSString'. Subject to fusion.
857+drop :: Int -> JSString -> JSString
858+drop = coerce T.drop
859+{-# INLINE [1] drop #-}
860+
861+{-# RULES
862+"JSSTRING drop -> fused" [~1] forall n t.
863+ drop n t = unstream (S.drop n (stream t))
864+"JSSTRING drop -> unfused" [1] forall n t.
865+ unstream (S.drop n (stream t)) = drop n t
866+ #-}
867+
868+-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after
869+-- dropping @n@ characters from the end of @t@.
870+--
871+-- Examples:
872+--
873+-- > dropEnd 3 "foobar" == "foo"
874+dropEnd :: Int -> JSString -> JSString
875+dropEnd = coerce T.dropEnd
876+
877+-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'JSString',
878+-- returns the longest prefix (possibly empty) of elements that
879+-- satisfy @p@. Subject to fusion.
880+takeWhile :: (Char -> Bool) -> JSString -> JSString
881+takeWhile = coerce T.takeWhile
882+{-# INLINE [1] takeWhile #-}
883+
884+{-# RULES
885+"TEXT takeWhile -> fused" [~1] forall p t.
886+ takeWhile p t = unstream (S.takeWhile p (stream t))
887+"TEXT takeWhile -> unfused" [1] forall p t.
888+ unstream (S.takeWhile p (stream t)) = takeWhile p t
889+ #-}
890+
891+-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
892+-- 'takeWhile' @p@ @t@. Subject to fusion.
893+dropWhile :: (Char -> Bool) -> JSString -> JSString
894+dropWhile = coerce T.dropWhile
895+{-# INLINE [1] dropWhile #-}
896+
897+{-# RULES
898+"TEXT dropWhile -> fused" [~1] forall p t.
899+ dropWhile p t = unstream (S.dropWhile p (stream t))
900+"TEXT dropWhile -> unfused" [1] forall p t.
901+ unstream (S.dropWhile p (stream t)) = dropWhile p t
902+ #-}
903+
904+-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
905+-- dropping characters that fail the predicate @p@ from the end of
906+-- @t@. Subject to fusion.
907+-- Examples:
908+--
909+-- > dropWhileEnd (=='.') "foo..." == "foo"
910+dropWhileEnd :: (Char -> Bool) -> JSString -> JSString
911+dropWhileEnd = coerce T.dropWhileEnd
912+{-# INLINE [1] dropWhileEnd #-}
913+
914+{-# RULES
915+"TEXT dropWhileEnd -> fused" [~1] forall p t.
916+ dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t))
917+"TEXT dropWhileEnd -> unfused" [1] forall p t.
918+ S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t
919+ #-}
920+
921+-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
922+-- dropping characters that fail the predicate @p@ from both the
923+-- beginning and end of @t@. Subject to fusion.
924+dropAround :: (Char -> Bool) -> JSString -> JSString
925+dropAround = coerce T.dropAround
926+{-# INLINE [1] dropAround #-}
927+
928+-- | /O(n)/ Remove leading white space from a string. Equivalent to:
929+--
930+-- > dropWhile isSpace
931+stripStart :: JSString -> JSString
932+stripStart = coerce T.stripStart
933+{-# INLINE [1] stripStart #-}
934+
935+-- | /O(n)/ Remove trailing white space from a string. Equivalent to:
936+--
937+-- > dropWhileEnd isSpace
938+stripEnd :: JSString -> JSString
939+stripEnd = coerce T.stripEnd
940+{-# INLINE [1] stripEnd #-}
941+
942+-- | /O(n)/ Remove leading and trailing white space from a string.
943+-- Equivalent to:
944+--
945+-- > dropAround isSpace
946+strip :: JSString -> JSString
947+strip = coerce T.strip
948+{-# INLINE [1] strip #-}
949+
950+-- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a
951+-- prefix of @t@ of length @n@, and whose second is the remainder of
952+-- the string. It is equivalent to @('take' n t, 'drop' n t)@.
953+splitAt :: Int -> JSString -> (JSString, JSString)
954+splitAt = coerce T.splitAt
955+{-# INLINE splitAt #-}
956+
957+-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
958+-- a pair whose first element is the longest prefix (possibly empty)
959+-- of @t@ of elements that satisfy @p@, and whose second is the
960+-- remainder of the list.
961+span :: (Char -> Bool) -> JSString -> (JSString, JSString)
962+span = coerce T.span
963+{-# INLINE span #-}
964+
965+-- | /O(n)/ 'break' is like 'span', but the prefix returned is
966+-- over elements that fail the predicate @p@.
967+break :: (Char -> Bool) -> JSString -> (JSString, JSString)
968+break = coerce T.break
969+{-# INLINE break #-}
970+
971+-- | /O(n)/ Group characters in a string according to a predicate.
972+groupBy :: (Char -> Char -> Bool) -> JSString -> [JSString]
973+groupBy = coerce T.groupBy
974+
975+-- | /O(n)/ Group characters in a string by equality.
976+group :: JSString -> [JSString]
977+group = coerce T.group
978+{-# INLINE group #-}
979+
980+group' :: JSString -> [JSString]
981+group' = coerce T.group
982+{-# INLINE group' #-}
983+
984+-- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest
985+-- first.
986+inits :: JSString -> [JSString]
987+inits = coerce T.inits
988+
989+-- | /O(n^2)/ Return all final segments of the given 'JSString', longest
990+-- first.
991+tails :: JSString -> [JSString]
992+tails = coerce T.tails
993+
994+-- $split
995+--
996+-- Splitting functions in this library do not perform character-wise
997+-- copies to create substrings; they just construct new 'JSString's that
998+-- are slices of the original.
999+
1000+-- | /O(m+n)/ Break a 'JSString' into pieces separated by the first 'JSString'
1001+-- argument (which cannot be empty), consuming the delimiter. An empty
1002+-- delimiter is invalid, and will cause an error to be raised.
1003+--
1004+-- Examples:
1005+--
1006+-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
1007+-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
1008+-- > splitOn "x" "x" == ["",""]
1009+--
1010+-- and
1011+--
1012+-- > intercalate s . splitOn s == id
1013+-- > splitOn (singleton c) == split (==c)
1014+--
1015+-- (Note: the string @s@ to split on above cannot be empty.)
1016+--
1017+-- In (unlikely) bad cases, this function's time complexity degrades
1018+-- towards /O(n*m)/.
1019+splitOn :: JSString
1020+ -- ^ String to split on. If this string is empty, an error
1021+ -- will occur.
1022+ -> JSString
1023+ -- ^ Input text.
1024+ -> [JSString]
1025+splitOn = coerce T.splitOn
1026+{-# INLINE [1] splitOn #-}
1027+
1028+-- RULES
1029+-- "JSSTRING splitOn/singleton -> split/==" [~1] forall c t.
1030+-- splitOn (singleton c) t = split (==c) t
1031+--
1032+
1033+splitOn' :: JSString
1034+ -- ^ String to split on. If this string is empty, an error
1035+ -- will occur.
1036+ -> JSString
1037+ -- ^ Input text.
1038+ -> [JSString]
1039+splitOn' = coerce T.splitOn
1040+{-# NOINLINE splitOn' #-}
1041+--- {-# INLINE [1] splitOn' #-}
1042+
1043+-- | /O(n)/ Splits a 'JSString' into components delimited by separators,
1044+-- where the predicate returns True for a separator element. The
1045+-- resulting components do not contain the separators. Two adjacent
1046+-- separators result in an empty component in the output. eg.
1047+--
1048+-- > split (=='a') "aabbaca" == ["","","bb","c",""]
1049+-- > split (=='a') "" == [""]
1050+split :: (Char -> Bool) -> JSString -> [JSString]
1051+split = coerce T.split
1052+{-# INLINE split #-}
1053+
1054+-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last
1055+-- element may be shorter than the other chunks, depending on the
1056+-- length of the input. Examples:
1057+--
1058+-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1059+-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1060+chunksOf :: Int -> JSString -> [JSString]
1061+chunksOf = coerce T.chunksOf
1062+{-# INLINE chunksOf #-}
1063+
1064+-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last
1065+-- element may be shorter than the other chunks, depending on the
1066+-- length of the input. Examples:
1067+--
1068+-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1069+-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1070+chunksOf' :: Int -> JSString -> [JSString]
1071+chunksOf' = coerce T.chunksOf
1072+{-# INLINE chunksOf' #-}
1073+
1074+-- ----------------------------------------------------------------------------
1075+-- * Searching
1076+
1077+-------------------------------------------------------------------------------
1078+-- ** Searching with a predicate
1079+
1080+-- | /O(n)/ The 'find' function takes a predicate and a 'JSString', and
1081+-- returns the first element matching the predicate, or 'Nothing' if
1082+-- there is no such element.
1083+find :: (Char -> Bool) -> JSString -> Maybe Char
1084+find = coerce T.find
1085+{-# INLINE find #-}
1086+
1087+-- | /O(n)/ The 'partition' function takes a predicate and a 'JSString',
1088+-- and returns the pair of 'JSString's with elements which do and do not
1089+-- satisfy the predicate, respectively; i.e.
1090+--
1091+-- > partition p t == (filter p t, filter (not . p) t)
1092+partition :: (Char -> Bool) -> JSString -> (JSString, JSString)
1093+partition = coerce T.partition
1094+{-# INLINE partition #-}
1095+
1096+-- | /O(n)/ 'filter', applied to a predicate and a 'JSString',
1097+-- returns a 'JSString' containing those characters that satisfy the
1098+-- predicate.
1099+filter :: (Char -> Bool) -> JSString -> JSString
1100+filter = coerce T.filter
1101+{-# INLINE filter #-}
1102+
1103+-- | /O(n+m)/ Find the first instance of @needle@ (which must be
1104+-- non-'null') in @haystack@. The first element of the returned tuple
1105+-- is the prefix of @haystack@ before @needle@ is matched. The second
1106+-- is the remainder of @haystack@, starting with the match.
1107+--
1108+-- Examples:
1109+--
1110+-- > breakOn "::" "a::b::c" ==> ("a", "::b::c")
1111+-- > breakOn "/" "foobar" ==> ("foobar", "")
1112+--
1113+-- Laws:
1114+--
1115+-- > append prefix match == haystack
1116+-- > where (prefix, match) = breakOn needle haystack
1117+--
1118+-- If you need to break a string by a substring repeatedly (e.g. you
1119+-- want to break on every instance of a substring), use 'breakOnAll'
1120+-- instead, as it has lower startup overhead.
1121+--
1122+-- In (unlikely) bad cases, this function's time complexity degrades
1123+-- towards /O(n*m)/.
1124+breakOn :: JSString -> JSString -> (JSString, JSString)
1125+breakOn = coerce T.breakOn
1126+{-# INLINE breakOn #-}
1127+
1128+-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
1129+-- string.
1130+--
1131+-- The first element of the returned tuple is the prefix of @haystack@
1132+-- up to and including the last match of @needle@. The second is the
1133+-- remainder of @haystack@, following the match.
1134+--
1135+-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c")
1136+breakOnEnd :: JSString -> JSString -> (JSString, JSString)
1137+breakOnEnd = coerce T.breakOnEnd
1138+{-# INLINE breakOnEnd #-}
1139+
1140+-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in
1141+-- @haystack@. Each element of the returned list consists of a pair:
1142+--
1143+-- * The entire string prior to the /k/th match (i.e. the prefix)
1144+--
1145+-- * The /k/th match, followed by the remainder of the string
1146+--
1147+-- Examples:
1148+--
1149+-- > breakOnAll "::" ""
1150+-- > ==> []
1151+-- > breakOnAll "/" "a/b/c/"
1152+-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")]
1153+--
1154+-- In (unlikely) bad cases, this function's time complexity degrades
1155+-- towards /O(n*m)/.
1156+--
1157+-- The @needle@ parameter may not be empty.
1158+breakOnAll :: JSString -- ^ @needle@ to search for
1159+ -> JSString -- ^ @haystack@ in which to search
1160+ -> [(JSString, JSString)]
1161+breakOnAll = coerce T.breakOnAll
1162+{-# INLINE breakOnAll #-}
1163+
1164+breakOnAll' :: JSString -- ^ @needle@ to search for
1165+ -> JSString -- ^ @haystack@ in which to search
1166+ -> [(JSString, JSString)]
1167+breakOnAll' = coerce T.breakOnAll
1168+{-# INLINE breakOnAll' #-}
1169+
1170+-------------------------------------------------------------------------------
1171+-- ** Indexing 'JSString's
1172+
1173+-- $index
1174+--
1175+-- If you think of a 'JSString' value as an array of 'Char' values (which
1176+-- it is not), you run the risk of writing inefficient code.
1177+--
1178+-- An idiom that is common in some languages is to find the numeric
1179+-- offset of a character or substring, then use that number to split
1180+-- or trim the searched string. With a 'JSString' value, this approach
1181+-- would require two /O(n)/ operations: one to perform the search, and
1182+-- one to operate from wherever the search ended.
1183+--
1184+-- For example, suppose you have a string that you want to split on
1185+-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of
1186+-- searching for the index of @\"::\"@ and taking the substrings
1187+-- before and after that index, you would instead use @breakOnAll \"::\"@.
1188+
1189+-- | /O(n)/ 'JSString' index (subscript) operator, starting from 0.
1190+index :: JSString -> Int -> Char
1191+index = coerce T.index
1192+{-# INLINE index #-}
1193+
1194+-- | /O(n)/ The 'findIndex' function takes a predicate and a 'JSString'
1195+-- and returns the index of the first element in the 'JSString' satisfying
1196+-- the predicate. Subject to fusion.
1197+findIndex :: (Char -> Bool) -> JSString -> Maybe Int
1198+findIndex = coerce T.findIndex
1199+{-# INLINE findIndex #-}
1200+
1201+-- | /O(n+m)/ The 'count' function returns the number of times the
1202+-- query string appears in the given 'JSString'. An empty query string is
1203+-- invalid, and will cause an error to be raised.
1204+--
1205+-- In (unlikely) bad cases, this function's time complexity degrades
1206+-- towards /O(n*m)/.
1207+count :: JSString -> JSString -> Int
1208+count = coerce T.count
1209+{-# INLINE [1] count #-}
1210+
1211+-- RULES
1212+-- "JSSTRING count/singleton -> countChar" [~1] forall c t.
1213+-- count (singleton c) t = countChar c t
1214+--
1215+
1216+-------------------------------------------------------------------------------
1217+-- * Zipping
1218+
1219+-- | /O(n)/ 'zip' takes two 'JSString's and returns a list of
1220+-- corresponding pairs of bytes. If one input 'JSString' is short,
1221+-- excess elements of the longer 'JSString' are discarded. This is
1222+-- equivalent to a pair of 'unpack' operations.
1223+zip :: JSString -> JSString -> [(Char,Char)]
1224+zip = coerce T.zip
1225+{-# INLINE [0] zip #-}
1226+
1227+-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
1228+-- given as the first argument, instead of a tupling function.
1229+-- Performs replacement on invalid scalar values.
1230+zipWith :: (Char -> Char -> Char) -> JSString -> JSString -> JSString
1231+zipWith = coerce T.zipWith
1232+{-# INLINE [0] zipWith #-}
1233+
1234+-- | /O(n)/ Breaks a 'JSString' up into a list of words, delimited by 'Char's
1235+-- representing white space.
1236+words :: JSString -> [JSString]
1237+words = coerce T.words
1238+{-# INLINE words #-}
1239+
1240+-- fixme: strict words' that allocates the whole list in one go
1241+words' :: JSString -> [JSString]
1242+words' = coerce T.words
1243+{-# INLINE words' #-}
1244+
1245+-- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at
1246+-- newline 'Char's. The resulting strings do not contain newlines.
1247+lines :: JSString -> [JSString]
1248+lines = coerce T.lines
1249+{-# INLINE lines #-}
1250+
1251+lines' :: JSString -> [JSString]
1252+lines' = coerce T.lines
1253+{-# INLINE lines' #-}
1254+
1255+{-
1256+-- | /O(n)/ Portably breaks a 'JSString' up into a list of 'JSString's at line
1257+-- boundaries.
1258+--
1259+-- A line boundary is considered to be either a line feed, a carriage
1260+-- return immediately followed by a line feed, or a carriage return.
1261+-- This accounts for both Unix and Windows line ending conventions,
1262+-- and for the old convention used on Mac OS 9 and earlier.
1263+lines' :: Text -> [Text]
1264+lines' ps | null ps = []
1265+ | otherwise = h : case uncons t of
1266+ Nothing -> []
1267+ Just (c,t')
1268+ | c == '\n' -> lines t'
1269+ | c == '\r' -> case uncons t' of
1270+ Just ('\n',t'') -> lines t''
1271+ _ -> lines t'
1272+ where (h,t) = span notEOL ps
1273+ notEOL c = c /= '\n' && c /= '\r'
1274+
1275+-}
1276+
1277+-- | /O(n)/ Joins lines, after appending a terminating newline to
1278+-- each.
1279+unlines :: [JSString] -> JSString
1280+unlines = coerce T.unlines
1281+{-# INLINE unlines #-}
1282+
1283+-- | /O(n)/ Joins words using single space characters.
1284+unwords :: [JSString] -> JSString
1285+unwords = coerce T.unwords
1286+{-# INLINE unwords #-}
1287+
1288+-- | /O(n)/ The 'isPrefixOf' function takes two 'JSString's and returns
1289+-- 'True' iff the first is a prefix of the second. Subject to fusion.
1290+isPrefixOf :: JSString -> JSString -> Bool
1291+isPrefixOf = coerce T.isPrefixOf
1292+{-# INLINE [1] isPrefixOf #-}
1293+
1294+{-# RULES
1295+"JSSTRING isPrefixOf -> fused" [~1] forall x y.
1296+ isPrefixOf x y = S.isPrefixOf (stream x) (stream y)
1297+"JSSTRING isPrefixOf -> unfused" [1] forall x y.
1298+ S.isPrefixOf (stream x) (stream y) = isPrefixOf x y
1299+ #-}
1300+
1301+-- | /O(n)/ The 'isSuffixOf' function takes two 'JSString's and returns
1302+-- 'True' iff the first is a suffix of the second.
1303+isSuffixOf :: JSString -> JSString -> Bool
1304+isSuffixOf = coerce T.isSuffixOf
1305+{-# INLINE isSuffixOf #-}
1306+
1307+-- | The 'isInfixOf' function takes two 'JSString's and returns
1308+-- 'True' iff the first is contained, wholly and intact, anywhere
1309+-- within the second.
1310+--
1311+-- Complexity depends on how the JavaScript engine implements
1312+-- String.prototype.find.
1313+isInfixOf :: JSString -> JSString -> Bool
1314+isInfixOf = coerce T.isInfixOf
1315+{-# INLINE [1] isInfixOf #-}
1316+
1317+{-# RULES
1318+"JSSTRING isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h.
1319+ isInfixOf (singleton n) h = S.elem n (S.stream h)
1320+ #-}
1321+
1322+-------------------------------------------------------------------------------
1323+-- * View patterns
1324+
1325+-- | /O(n)/ Return the suffix of the second string if its prefix
1326+-- matches the entire first string.
1327+--
1328+-- Examples:
1329+--
1330+-- > stripPrefix "foo" "foobar" == Just "bar"
1331+-- > stripPrefix "" "baz" == Just "baz"
1332+-- > stripPrefix "foo" "quux" == Nothing
1333+--
1334+-- This is particularly useful with the @ViewPatterns@ extension to
1335+-- GHC, as follows:
1336+--
1337+-- > {-# LANGUAGE ViewPatterns #-}
1338+-- > import Data.Text as T
1339+-- >
1340+-- > fnordLength :: JSString -> Int
1341+-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1342+-- > fnordLength _ = -1
1343+stripPrefix :: JSString -> JSString -> Maybe JSString
1344+stripPrefix = coerce T.stripPrefix
1345+{-# INLINE stripPrefix #-}
1346+
1347+-- | /O(n)/ Find the longest non-empty common prefix of two strings
1348+-- and return it, along with the suffixes of each string at which they
1349+-- no longer match.
1350+--
1351+-- If the strings do not have a common prefix or either one is empty,
1352+-- this function returns 'Nothing'.
1353+--
1354+-- Examples:
1355+--
1356+-- > commonPrefixes "foobar" "fooquux" == Just ("foo","bar","quux")
1357+-- > commonPrefixes "veeble" "fetzer" == Nothing
1358+-- > commonPrefixes "" "baz" == Nothing
1359+commonPrefixes :: JSString -> JSString -> Maybe (JSString,JSString,JSString)
1360+commonPrefixes = coerce T.commonPrefixes
1361+{-# INLINE commonPrefixes #-}
1362+
1363+-- | /O(n)/ Return the prefix of the second string if its suffix
1364+-- matches the entire first string.
1365+--
1366+-- Examples:
1367+--
1368+-- > stripSuffix "bar" "foobar" == Just "foo"
1369+-- > stripSuffix "" "baz" == Just "baz"
1370+-- > stripSuffix "foo" "quux" == Nothing
1371+--
1372+-- This is particularly useful with the @ViewPatterns@ extension to
1373+-- GHC, as follows:
1374+--
1375+-- > {-# LANGUAGE ViewPatterns #-}
1376+-- > import Data.Text as T
1377+-- >
1378+-- > quuxLength :: Text -> Int
1379+-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1380+-- > quuxLength _ = -1
1381+stripSuffix :: JSString -> JSString -> Maybe JSString
1382+stripSuffix = coerce T.stripSuffix
1383+{-# INLINE stripSuffix #-}
1384+
1385+---- | Add a list of non-negative numbers. Errors out on overflow.
1386+--sumP :: String -> [Int] -> Int
1387+--sumP fun = go 0
1388+-- where go !a (x:xs)
1389+-- | ax >= 0 = go ax xs
1390+-- | otherwise = overflowError fun
1391+-- where ax = a + x
1392+-- go a _ = a
1393+--
1394+--emptyError :: String -> a
1395+--emptyError fun = P.error $ "Data.JSString." ++ fun ++ ": empty input"
1396+--
1397+--overflowError :: String -> a
1398+--overflowError fun = P.error $ "Data.JSString." ++ fun ++ ": size overflow"
1399+--
1400+--charWidth :: Int# -> Int#
1401+--charWidth cp | isTrue# (cp >=# 0x10000#) = 2#
1402+-- | otherwise = 1#
1403+--{-# INLINE charWidth #-}
jsaddle/src-ghc/Data/JSString/Internal.hsnew file+1
@@ -0,0 +1 @@
1+module Data.JSString.Internal where
jsaddle/src-ghc/Data/JSString/Internal/Fusion.hsnew file+127
@@ -0,0 +1,127 @@
1+{-# LANGUAGE BangPatterns, MagicHash
2+ #-}
3+module Data.JSString.Internal.Fusion ( -- * Types
4+ Stream(..)
5+ , Step(..)
6+
7+ -- * Creation and elimination
8+ , stream
9+ , unstream
10+ , reverseStream
11+
12+ , length
13+
14+ -- * Transformations
15+ , reverse
16+
17+ -- * Construction
18+ -- ** Scans
19+ , reverseScanr
20+
21+ -- ** Accumulating maps
22+ , mapAccumL
23+
24+ -- ** Generation and unfolding
25+ , unfoldrN
26+
27+ -- * Indexing
28+ , index
29+ , findIndex
30+ , countChar
31+ ) where
32+
33+import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#))
34+
35+import Prelude hiding (length, reverse)
36+import qualified Data.Text.Internal.Fusion as T
37+import Data.Char
38+import Data.Coerce (coerce)
39+
40+import Data.JSString.Internal.Type (JSString(..))
41+import qualified Data.JSString.Internal.Type as I
42+import Data.JSString.Internal.Fusion.Types
43+import qualified Data.JSString.Internal.Fusion.Common as S
44+
45+import System.IO.Unsafe
46+
47+import GHCJS.Prim
48+
49+default (Int)
50+
51+-- | /O(n)/ Convert a 'JSString' into a 'Stream Char'.
52+stream :: JSString -> Stream Char
53+stream = coerce T.stream
54+{-# INLINE [0] stream #-}
55+
56+-- | /O(n)/ Convert a 'JSString' into a 'Stream Char', but iterate
57+-- backwards.
58+reverseStream :: JSString -> Stream Char
59+reverseStream = coerce T.reverseStream
60+{-# INLINE [0] reverseStream #-}
61+
62+-- | /O(n)/ Convert a 'Stream Char' into a 'JSString'.
63+unstream :: Stream Char -> JSString
64+unstream = coerce T.unstream
65+{-# INLINE [0] unstream #-}
66+{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
67+
68+
69+-- ----------------------------------------------------------------------------
70+-- * Basic stream functions
71+
72+--runJSString :: ((a -> IO a) -> IO a) -> a
73+--runJSString f = unsafePerformIO (f pure)
74+
75+length :: Stream Char -> Int
76+length = S.lengthI
77+{-# INLINE[0] length #-}
78+
79+-- | /O(n)/ Reverse the characters of a string.
80+reverse :: Stream Char -> JSString
81+reverse = coerce T.reverse
82+{-# INLINE [0] reverse #-}
83+
84+-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
85+-- the input and result reversed.
86+reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
87+reverseScanr = coerce T.reverseScanr
88+{-# INLINE reverseScanr #-}
89+
90+-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
91+-- value. However, the length of the result is limited by the
92+-- first argument to 'unfoldrN'. This function is more efficient than
93+-- 'unfoldr' when the length of the result is known.
94+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
95+unfoldrN n = S.unfoldrNI n
96+{-# INLINE [0] unfoldrN #-}
97+
98+-------------------------------------------------------------------------------
99+-- ** Indexing streams
100+
101+-- | /O(n)/ stream index (subscript) operator, starting from 0.
102+index :: Stream Char -> Int -> Char
103+index = S.indexI
104+{-# INLINE [0] index #-}
105+
106+-- | The 'findIndex' function takes a predicate and a stream and
107+-- returns the index of the first element in the stream
108+-- satisfying the predicate.
109+findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
110+findIndex = S.findIndexI
111+{-# INLINE [0] findIndex #-}
112+
113+-- | /O(n)/ The 'count' function returns the number of times the query
114+-- element appears in the given stream.
115+countChar :: Char -> Stream Char -> Int
116+countChar = S.countCharI
117+{-# INLINE [0] countChar #-}
118+
119+-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
120+-- function to each element of a 'Text', passing an accumulating
121+-- parameter from left to right, and returns a final 'JSString'.
122+mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, JSString)
123+mapAccumL a b c = coerce (T.mapAccumL a b c)
124+{-# INLINE [0] mapAccumL #-}
125+
126+-------------------------------------------------------------------------------
127+
jsaddle/src-ghc/Data/JSString/Internal/Fusion/CaseMapping.hsnew file+570
@@ -0,0 +1,570 @@
1+{-# LANGUAGE Rank2Types #-}
2+-- AUTOMATICALLY GENERATED - DO NOT EDIT
3+-- Generated by scripts/SpecialCasing.hs
4+-- CaseFolding-6.3.0.txt
5+-- Date: 2012-12-20, 22:14:35 GMT [MD]
6+-- SpecialCasing-6.3.0.txt
7+-- Date: 2013-05-08, 13:54:51 GMT [MD]
8+
9+module Data.JSString.Internal.Fusion.CaseMapping where
10+import Data.Char
11+import Data.JSString.Internal.Fusion.Types
12+
13+upperMapping :: forall s. Char -> s -> Step (CC s) Char
14+{-# INLINE upperMapping #-}
15+-- LATIN SMALL LETTER SHARP S
16+upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000')
17+-- LATIN SMALL LIGATURE FF
18+upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000')
19+-- LATIN SMALL LIGATURE FI
20+upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000')
21+-- LATIN SMALL LIGATURE FL
22+upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000')
23+-- LATIN SMALL LIGATURE FFI
24+upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049')
25+-- LATIN SMALL LIGATURE FFL
26+upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c')
27+-- LATIN SMALL LIGATURE LONG S T
28+upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000')
29+-- LATIN SMALL LIGATURE ST
30+upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000')
31+-- ARMENIAN SMALL LIGATURE ECH YIWN
32+upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000')
33+-- ARMENIAN SMALL LIGATURE MEN NOW
34+upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000')
35+-- ARMENIAN SMALL LIGATURE MEN ECH
36+upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000')
37+-- ARMENIAN SMALL LIGATURE MEN INI
38+upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000')
39+-- ARMENIAN SMALL LIGATURE VEW NOW
40+upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000')
41+-- ARMENIAN SMALL LIGATURE MEN XEH
42+upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000')
43+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
44+upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
45+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
46+upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
47+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
48+upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
49+-- LATIN SMALL LETTER J WITH CARON
50+upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
51+-- LATIN SMALL LETTER H WITH LINE BELOW
52+upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
53+-- LATIN SMALL LETTER T WITH DIAERESIS
54+upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
55+-- LATIN SMALL LETTER W WITH RING ABOVE
56+upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
57+-- LATIN SMALL LETTER Y WITH RING ABOVE
58+upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
59+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
60+upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
61+-- GREEK SMALL LETTER UPSILON WITH PSILI
62+upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
63+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
64+upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
65+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
66+upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
67+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
68+upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
69+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
70+upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
71+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
72+upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
73+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
74+upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
75+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
76+upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
77+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
78+upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
79+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
80+upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
81+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
82+upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
83+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
84+upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
85+-- GREEK SMALL LETTER RHO WITH PSILI
86+upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
87+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
88+upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
89+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
90+upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
91+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
92+upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
93+-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI
94+upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000')
95+-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI
96+upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000')
97+-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI
98+upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')
99+-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI
100+upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')
101+-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI
102+upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')
103+-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI
104+upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')
105+-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
106+upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')
107+-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
108+upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')
109+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
110+upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000')
111+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
112+upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000')
113+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
114+upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')
115+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
116+upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')
117+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
118+upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')
119+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
120+upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')
121+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
122+upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')
123+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
124+upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')
125+-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI
126+upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000')
127+-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI
128+upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000')
129+-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI
130+upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')
131+-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI
132+upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')
133+-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI
134+upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')
135+-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI
136+upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')
137+-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
138+upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')
139+-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
140+upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')
141+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
142+upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000')
143+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
144+upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000')
145+-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
146+upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')
147+-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
148+upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')
149+-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
150+upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')
151+-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
152+upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')
153+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
154+upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')
155+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
156+upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')
157+-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI
158+upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000')
159+-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI
160+upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000')
161+-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI
162+upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')
163+-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI
164+upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')
165+-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI
166+upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')
167+-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI
168+upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')
169+-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
170+upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')
171+-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
172+upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')
173+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
174+upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000')
175+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
176+upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000')
177+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
178+upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')
179+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
180+upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')
181+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
182+upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')
183+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
184+upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')
185+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
186+upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')
187+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
188+upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')
189+-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI
190+upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000')
191+-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
192+upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000')
193+-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI
194+upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000')
195+-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
196+upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000')
197+-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI
198+upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000')
199+-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
200+upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000')
201+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
202+upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000')
203+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
204+upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000')
205+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
206+upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000')
207+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
208+upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000')
209+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
210+upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000')
211+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
212+upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000')
213+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
214+upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399')
215+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
216+upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399')
217+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
218+upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399')
219+upperMapping c s = Yield (toUpper c) (CC s '\0' '\0')
220+lowerMapping :: forall s. Char -> s -> Step (CC s) Char
221+{-# INLINE lowerMapping #-}
222+-- LATIN CAPITAL LETTER I WITH DOT ABOVE
223+lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
224+lowerMapping c s = Yield (toLower c) (CC s '\0' '\0')
225+titleMapping :: forall s. Char -> s -> Step (CC s) Char
226+{-# INLINE titleMapping #-}
227+-- LATIN SMALL LETTER SHARP S
228+titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000')
229+-- LATIN SMALL LIGATURE FF
230+titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000')
231+-- LATIN SMALL LIGATURE FI
232+titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000')
233+-- LATIN SMALL LIGATURE FL
234+titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000')
235+-- LATIN SMALL LIGATURE FFI
236+titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069')
237+-- LATIN SMALL LIGATURE FFL
238+titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c')
239+-- LATIN SMALL LIGATURE LONG S T
240+titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000')
241+-- LATIN SMALL LIGATURE ST
242+titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000')
243+-- ARMENIAN SMALL LIGATURE ECH YIWN
244+titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000')
245+-- ARMENIAN SMALL LIGATURE MEN NOW
246+titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000')
247+-- ARMENIAN SMALL LIGATURE MEN ECH
248+titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000')
249+-- ARMENIAN SMALL LIGATURE MEN INI
250+titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000')
251+-- ARMENIAN SMALL LIGATURE VEW NOW
252+titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000')
253+-- ARMENIAN SMALL LIGATURE MEN XEH
254+titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000')
255+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
256+titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
257+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
258+titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
259+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
260+titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
261+-- LATIN SMALL LETTER J WITH CARON
262+titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
263+-- LATIN SMALL LETTER H WITH LINE BELOW
264+titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
265+-- LATIN SMALL LETTER T WITH DIAERESIS
266+titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
267+-- LATIN SMALL LETTER W WITH RING ABOVE
268+titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
269+-- LATIN SMALL LETTER Y WITH RING ABOVE
270+titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
271+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
272+titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
273+-- GREEK SMALL LETTER UPSILON WITH PSILI
274+titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
275+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
276+titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
277+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
278+titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
279+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
280+titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
281+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
282+titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
283+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
284+titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
285+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
286+titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
287+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
288+titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
289+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
290+titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
291+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
292+titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
293+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
294+titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
295+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
296+titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
297+-- GREEK SMALL LETTER RHO WITH PSILI
298+titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
299+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
300+titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
301+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
302+titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
303+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
304+titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
305+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
306+titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000')
307+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
308+titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000')
309+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
310+titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000')
311+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
312+titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000')
313+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
314+titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000')
315+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
316+titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000')
317+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
318+titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345')
319+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
320+titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345')
321+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
322+titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345')
323+titleMapping c s = Yield (toTitle c) (CC s '\0' '\0')
324+foldMapping :: forall s. Char -> s -> Step (CC s) Char
325+{-# INLINE foldMapping #-}
326+-- MICRO SIGN
327+foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000')
328+-- LATIN SMALL LETTER SHARP S
329+foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000')
330+-- LATIN CAPITAL LETTER I WITH DOT ABOVE
331+foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
332+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
333+foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000')
334+-- LATIN SMALL LETTER LONG S
335+foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000')
336+-- LATIN SMALL LETTER J WITH CARON
337+foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000')
338+-- COMBINING GREEK YPOGEGRAMMENI
339+foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000')
340+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
341+foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301')
342+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
343+foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301')
344+-- GREEK SMALL LETTER FINAL SIGMA
345+foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000')
346+-- GREEK BETA SYMBOL
347+foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000')
348+-- GREEK THETA SYMBOL
349+foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000')
350+-- GREEK PHI SYMBOL
351+foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000')
352+-- GREEK PI SYMBOL
353+foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000')
354+-- GREEK KAPPA SYMBOL
355+foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000')
356+-- GREEK RHO SYMBOL
357+foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000')
358+-- GREEK LUNATE EPSILON SYMBOL
359+foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000')
360+-- ARMENIAN SMALL LIGATURE ECH YIWN
361+foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000')
362+-- GEORGIAN CAPITAL LETTER YN
363+foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000')
364+-- GEORGIAN CAPITAL LETTER AEN
365+foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000')
366+-- LATIN SMALL LETTER H WITH LINE BELOW
367+foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000')
368+-- LATIN SMALL LETTER T WITH DIAERESIS
369+foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000')
370+-- LATIN SMALL LETTER W WITH RING ABOVE
371+foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000')
372+-- LATIN SMALL LETTER Y WITH RING ABOVE
373+foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000')
374+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
375+foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000')
376+-- LATIN SMALL LETTER LONG S WITH DOT ABOVE
377+foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000')
378+-- LATIN CAPITAL LETTER SHARP S
379+foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000')
380+-- GREEK SMALL LETTER UPSILON WITH PSILI
381+foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000')
382+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
383+foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300')
384+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
385+foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301')
386+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
387+foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342')
388+-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI
389+foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')
390+-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI
391+foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')
392+-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI
393+foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')
394+-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI
395+foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')
396+-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI
397+foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')
398+-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI
399+foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')
400+-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
401+foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')
402+-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
403+foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')
404+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
405+foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')
406+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
407+foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')
408+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
409+foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')
410+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
411+foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')
412+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
413+foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')
414+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
415+foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')
416+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
417+foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')
418+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
419+foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')
420+-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI
421+foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')
422+-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI
423+foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')
424+-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI
425+foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')
426+-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI
427+foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')
428+-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI
429+foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')
430+-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI
431+foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')
432+-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
433+foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')
434+-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
435+foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')
436+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
437+foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')
438+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
439+foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')
440+-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
441+foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')
442+-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
443+foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')
444+-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
445+foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')
446+-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
447+foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')
448+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
449+foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')
450+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
451+foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')
452+-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI
453+foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')
454+-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI
455+foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')
456+-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI
457+foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')
458+-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI
459+foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')
460+-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI
461+foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')
462+-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI
463+foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')
464+-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI
465+foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')
466+-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI
467+foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')
468+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
469+foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')
470+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
471+foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')
472+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
473+foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')
474+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
475+foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')
476+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
477+foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')
478+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
479+foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')
480+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
481+foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')
482+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
483+foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')
484+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
485+foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000')
486+-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI
487+foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')
488+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
489+foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000')
490+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
491+foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000')
492+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
493+foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9')
494+-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
495+foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')
496+-- GREEK PROSGEGRAMMENI
497+foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000')
498+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
499+foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000')
500+-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI
501+foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')
502+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
503+foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000')
504+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
505+foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000')
506+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
507+foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9')
508+-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
509+foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')
510+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
511+foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300')
512+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
513+foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301')
514+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
515+foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000')
516+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
517+foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342')
518+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
519+foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300')
520+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
521+foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301')
522+-- GREEK SMALL LETTER RHO WITH PSILI
523+foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000')
524+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
525+foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000')
526+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
527+foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342')
528+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
529+foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000')
530+-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI
531+foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
532+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
533+foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000')
534+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
535+foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000')
536+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
537+foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9')
538+-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
539+foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
540+-- COPTIC CAPITAL LETTER BOHAIRIC KHEI
541+foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000')
542+-- LATIN CAPITAL LETTER C WITH BAR
543+foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000')
544+-- LATIN CAPITAL LETTER H WITH HOOK
545+foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000')
546+-- LATIN SMALL LIGATURE FF
547+foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000')
548+-- LATIN SMALL LIGATURE FI
549+foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000')
550+-- LATIN SMALL LIGATURE FL
551+foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000')
552+-- LATIN SMALL LIGATURE FFI
553+foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069')
554+-- LATIN SMALL LIGATURE FFL
555+foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c')
556+-- LATIN SMALL LIGATURE LONG S T
557+foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000')
558+-- LATIN SMALL LIGATURE ST
559+foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000')
560+-- ARMENIAN SMALL LIGATURE MEN NOW
561+foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000')
562+-- ARMENIAN SMALL LIGATURE MEN ECH
563+foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000')
564+-- ARMENIAN SMALL LIGATURE MEN INI
565+foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000')
566+-- ARMENIAN SMALL LIGATURE VEW NOW
567+foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000')
568+-- ARMENIAN SMALL LIGATURE MEN XEH
569+foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000')
570+foldMapping c s = Yield (toLower c) (CC s '\0' '\0')
jsaddle/src-ghc/Data/JSString/Internal/Fusion/Common.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# LANGUAGE BangPatterns, MagicHash, RankNTypes #-}
2+
3+module Data.JSString.Internal.Fusion.Common ( -- * Creation and elimination
4+ singleton
5+ , streamList
6+ , unstreamList
7+ , streamCString#
8+
9+ -- * Basic interface
10+ , cons
11+ , snoc
12+ , append
13+ , head
14+ , uncons
15+ , last
16+ , tail
17+ , init
18+ , null
19+ , lengthI
20+ , compareLengthI
21+ , isSingleton
22+
23+ -- * Transformations
24+ , map
25+ , intercalate
26+ , intersperse
27+
28+ -- ** Case conversion
29+ -- $case
30+ , toCaseFold
31+ , toLower
32+ , toTitle
33+ , toUpper
34+
35+ -- ** Justification
36+ , justifyLeftI
37+
38+ -- * Folds
39+ , foldl
40+ , foldl'
41+ , foldl1
42+ , foldl1'
43+ , foldr
44+ , foldr1
45+
46+ -- ** Special folds
47+ , concat
48+ , concatMap
49+ , any
50+ , all
51+ , maximum
52+ , minimum
53+
54+ -- * Construction
55+ -- ** Scans
56+ , scanl
57+
58+ -- ** Accumulating maps
59+ -- , mapAccumL
60+
61+ -- ** Generation and unfolding
62+ , replicateCharI
63+ , replicateI
64+ , unfoldr
65+ , unfoldrNI
66+
67+ -- * Substrings
68+ -- ** Breaking strings
69+ , take
70+ , drop
71+ , takeWhile
72+ , dropWhile
73+
74+ -- * Predicates
75+ , isPrefixOf
76+
77+ -- * Searching
78+ , elem
79+ , filter
80+
81+ -- * Indexing
82+ , findBy
83+ , indexI
84+ , findIndexI
85+ , countCharI
86+
87+ -- * Zipping and unzipping
88+ , zipWith
89+ ) where
90+
91+import Data.Text.Internal.Fusion.Common
92+import Prelude ()
jsaddle/src-ghc/Data/JSString/Internal/Fusion/Types.hsnew file+122
@@ -0,0 +1,122 @@
1+{-# LANGUAGE BangPatterns, ExistentialQuantification #-}
2+-- |
3+-- Module : Data.Text.Internal.Fusion.Types
4+-- Copyright : (c) Tom Harper 2008-2009,
5+-- (c) Bryan O'Sullivan 2009,
6+-- (c) Duncan Coutts 2009,
7+-- (c) Jasper Van der Jeugt 2011
8+--
9+-- License : BSD-style
10+-- Maintainer : bos@serpentine.com
11+-- Stability : experimental
12+-- Portability : GHC
13+--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
18+-- Core stream fusion functionality for text.
19+
20+module Data.JSString.Internal.Fusion.Types
21+ (
22+ CC(..)
23+-- , M(..)
24+-- , M8
25+ , PairS(..)
26+ , RS(..)
27+ , Step(..)
28+ , Stream(..)
29+-- , Switch(..)
30+ , empty
31+ ) where
32+
33+import Data.Text.Internal.Fusion.Types
34+-- import Data.Text.Internal.Fusion.Size
35+import Data.Word (Word8)
36+
37+---- | Specialised tuple for case conversion.
38+--data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
39+--
40+---- | Specialised, strict Maybe-like type.
41+--data M a = N
42+-- | J !a
43+--
44+--type M8 = M Word8
45+--
46+---- Restreaming state.
47+--data RS s
48+-- = RS0 !s
49+-- | RS1 !s {-# UNPACK #-} !Word8
50+-- | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
51+-- | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
52+--
53+--infixl 2 :*:
54+--data PairS a b = !a :*: !b
55+-- -- deriving (Eq, Ord, Show)
56+--
57+---- | Allow a function over a stream to switch between two states.
58+--data Switch = S1 | S2
59+--
60+--data Step s a = Done
61+-- | Skip !s
62+-- | Yield !a !s
63+--
64+--{-
65+--instance (Show a) => Show (Step s a)
66+-- where show Done = "Done"
67+-- show (Skip _) = "Skip"
68+-- show (Yield x _) = "Yield " ++ show x
69+---}
70+--
71+--instance (Eq a) => Eq (Stream a) where
72+-- (==) = eq
73+--
74+--instance (Ord a) => Ord (Stream a) where
75+-- compare = cmp
76+--
77+---- The length hint in a Stream has two roles. If its value is zero,
78+---- we trust it, and treat the stream as empty. Otherwise, we treat it
79+---- as a hint: it should usually be accurate, so we use it when
80+---- unstreaming to decide what size array to allocate. However, the
81+---- unstreaming functions must be able to cope with the hint being too
82+---- small or too large.
83+--
84+--data Stream a =
85+-- forall s. Stream
86+-- (s -> Step s a) -- stepper function
87+-- !s -- current state
88+--
89+---- | /O(n)/ Determines if two streams are equal.
90+--eq :: (Eq a) => Stream a -> Stream a -> Bool
91+--eq (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
92+-- where
93+-- loop Done Done = True
94+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
95+-- loop (Skip s1') x2 = loop (next1 s1') x2
96+-- loop x1 (Skip s2') = loop x1 (next2 s2')
97+-- loop Done _ = False
98+-- loop _ Done = False
99+-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
100+-- loop (next1 s1') (next2 s2')
101+--{-# INLINE [0] eq #-}
102+--
103+--cmp :: (Ord a) => Stream a -> Stream a -> Ordering
104+--cmp (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
105+-- where
106+-- loop Done Done = EQ
107+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
108+-- loop (Skip s1') x2 = loop (next1 s1') x2
109+-- loop x1 (Skip s2') = loop x1 (next2 s2')
110+-- loop Done _ = LT
111+-- loop _ Done = GT
112+-- loop (Yield x1 s1') (Yield x2 s2') =
113+-- case compare x1 x2 of
114+-- EQ -> loop (next1 s1') (next2 s2')
115+-- other -> other
116+--{-# INLINE [0] cmp #-}
117+--
118+---- | The empty stream.
119+--empty :: Stream a
120+--empty = Stream next ()
121+-- where next _ = Done
122+--{-# INLINE [0] empty #-}
jsaddle/src-ghc/Data/JSString/Internal/Search.hsnew file+11
@@ -0,0 +1,11 @@
1+module Data.JSString.Internal.Search ( indices
2+ ) where
3+
4+import Data.Coerce (coerce)
5+
6+import Data.JSString.Internal.Type (JSString(..))
7+
8+import qualified Data.Text.Internal.Search as T
9+
10+indices :: JSString -> JSString -> [Int]
11+indices = coerce T.indices
jsaddle/src-ghc/Data/JSString/Internal/Type.hsnew file+115
@@ -0,0 +1,115 @@
1+{-# LANGUAGE DeriveDataTypeable, UnboxedTuples, MagicHash,
2+ BangPatterns, GeneralizedNewtypeDeriving #-}
3+{-# OPTIONS_HADDOCK not-home #-}
4+module Data.JSString.Internal.Type ( JSString(..)
5+ , empty
6+ , empty_
7+ , safe
8+ , firstf
9+ ) where
10+
11+ {-
12+ -- * Construction
13+ , text
14+ , textP
15+ -- * Safety
16+ , safe
17+ -- * Code that must be here for accessibility
18+ , empty
19+ , empty_
20+ -- * Utilities
21+ , firstf
22+ -- * Checked multiplication
23+ , mul
24+ , mul32
25+ , mul64
26+ -- * Debugging
27+ , showText
28+
29+ ) where
30+-}
31+import Control.DeepSeq
32+
33+import Data.Coerce (coerce)
34+import Data.Text (Text)
35+import qualified Data.Text as T (empty)
36+import Data.String (IsString)
37+import Data.Aeson (ToJSON(..), FromJSON(..))
38+import Data.Data (Data)
39+-- import Data.Text.Internal.Unsafe.Char (ord)
40+import Data.Typeable (Typeable)
41+import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#)
42+
43+-- | A wrapper around a JavaScript string
44+newtype JSString = JSString Text deriving(Show, Read, IsString, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable)
45+
46+instance NFData JSString where rnf !x = ()
47+
48+-- | /O(1)/ The empty 'JSString'.
49+empty :: JSString
50+empty = coerce T.empty
51+{-# INLINE [1] empty #-}
52+
53+-- | A non-inlined version of 'empty'.
54+empty_ :: JSString
55+empty_ = coerce T.empty
56+{-# NOINLINE empty_ #-}
57+
58+safe :: Char -> Char
59+safe c@(C# cc)
60+ | isTrue# (andI# (ord# cc) 0x1ff800# /=# 0xd800#) = c
61+ | otherwise = '\xfffd'
62+{-# INLINE [0] safe #-}
63+
64+
65+-- | Apply a function to the first element of an optional pair.
66+firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
67+firstf f (Just (a, b)) = Just (f a, b)
68+firstf _ Nothing = Nothing
69+
70+{-
71+-- | Checked multiplication. Calls 'error' if the result would
72+-- overflow.
73+mul :: Int -> Int -> Int
74+#if WORD_SIZE_IN_BITS == 64
75+mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b
76+#else
77+mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b
78+#endif
79+{-# INLINE mul #-}
80+infixl 7 `mul`
81+
82+-- | Checked multiplication. Calls 'error' if the result would
83+-- overflow.
84+mul64 :: Int64 -> Int64 -> Int64
85+mul64 a b
86+ | a >= 0 && b >= 0 = mul64_ a b
87+ | a >= 0 = -mul64_ a (-b)
88+ | b >= 0 = -mul64_ (-a) b
89+ | otherwise = mul64_ (-a) (-b)
90+{-# INLINE mul64 #-}
91+infixl 7 `mul64`
92+
93+mul64_ :: Int64 -> Int64 -> Int64
94+mul64_ a b
95+ | ahi > 0 && bhi > 0 = error "overflow"
96+ | top > 0x7fffffff = error "overflow"
97+ | total < 0 = error "overflow"
98+ | otherwise = total
99+ where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)
100+ (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)
101+ top = ahi * blo + alo * bhi
102+ total = (top `shiftL` 32) + alo * blo
103+{-# INLINE mul64_ #-}
104+
105+-- | Checked multiplication. Calls 'error' if the result would
106+-- overflow.
107+mul32 :: Int32 -> Int32 -> Int32
108+mul32 a b = case fromIntegral a * fromIntegral b of
109+ ab | ab < min32 || ab > max32 -> error "overflow"
110+ | otherwise -> fromIntegral ab
111+ where min32 = -0x80000000 :: Int64
112+ max32 = 0x7fffffff
113+{-# INLINE mul32 #-}
114+infixl 7 `mul32`
115+-}
jsaddle/src-ghc/Data/JSString/Text.hsnew file+52
@@ -0,0 +1,52 @@
1+{- | Conversion between 'Data.Text.Text' and 'Data.JSString.JSString' -}
2+
3+module Data.JSString.Text
4+ ( textToJSString
5+ , textFromJSString
6+ , lazyTextToJSString
7+ , lazyTextFromJSString
8+ , textFromJSVal
9+ , lazyTextFromJSVal
10+ ) where
11+
12+import GHCJS.Prim.Internal (JSVal)
13+
14+import Data.Coerce (coerce)
15+import qualified Data.Text as T
16+import qualified Data.Text.Lazy as TL
17+
18+import Data.JSString.Internal.Type
19+
20+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..))
21+import Language.Javascript.JSaddle.Native.Internal
22+ (valueToString)
23+
24+textToJSString :: T.Text -> JSString
25+textToJSString = coerce
26+{-# INLINE textToJSString #-}
27+
28+textFromJSString :: JSString -> T.Text
29+textFromJSString = coerce
30+{-# INLINE textFromJSString #-}
31+
32+lazyTextToJSString :: TL.Text -> JSString
33+lazyTextToJSString = coerce . TL.toStrict
34+{-# INLINE lazyTextToJSString #-}
35+
36+lazyTextFromJSString :: JSString -> TL.Text
37+lazyTextFromJSString = TL.fromStrict . coerce
38+{-# INLINE lazyTextFromJSString #-}
39+
40+-- | returns the empty Text if not a string
41+textFromJSVal :: JSVal -> GHCJSPure T.Text
42+textFromJSVal j = GHCJSPure $ textFromJSString <$> valToJSString j
43+{-# INLINE textFromJSVal #-}
44+
45+-- | returns the empty Text if not a string
46+lazyTextFromJSVal :: JSVal -> GHCJSPure TL.Text
47+lazyTextFromJSVal j = GHCJSPure $ lazyTextFromJSString <$> valToJSString j
48+{-# INLINE lazyTextFromJSVal #-}
49+
50+valToJSString :: JSVal -> JSM JSString
51+valToJSString = valueToString
52+{-# INLINE valToJSString #-}
jsaddle/src-ghc/GHCJS/Buffer.hsnew file+117
@@ -0,0 +1,117 @@
1+module GHCJS.Buffer
2+ ( Buffer
3+ , MutableBuffer
4+ , create
5+ , createFromArrayBuffer
6+ , thaw, freeze, clone
7+ -- * JavaScript properties
8+ , byteLength
9+ , getArrayBuffer
10+ , getUint8Array
11+ , getUint16Array
12+ , getInt32Array
13+ , getDataView
14+ , getFloat32Array
15+ , getFloat64Array
16+ -- * bytestring
17+ , toByteString, fromByteString
18+ ) where
19+
20+import GHCJS.Buffer.Types
21+
22+import Control.Lens.Operators ((^.))
23+
24+import Data.ByteString (ByteString)
25+import qualified Data.ByteString as BS
26+import qualified Data.ByteString.Base64 as B64 (encode, decode)
27+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
28+
29+import qualified JavaScript.TypedArray.Internal.Types as I
30+import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))
31+import JavaScript.TypedArray.DataView.Internal (SomeDataView(..))
32+
33+import GHCJS.Marshal (FromJSVal(..))
34+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..), ghcjsPure)
35+import Language.Javascript.JSaddle.Object (js, js2, jsg1, jsg3)
36+
37+create :: Int -> JSM MutableBuffer
38+create n | n >= 0 = SomeBuffer <$> jsg1 "h$newByteArray" n
39+ | otherwise = error "create: negative size"
40+{-# INLINE create #-}
41+
42+createFromArrayBuffer :: SomeArrayBuffer any -> GHCJSPure (SomeBuffer any)
43+createFromArrayBuffer (SomeArrayBuffer buf) = GHCJSPure $ SomeBuffer <$> jsg1 "h$wrapBuffer" buf
44+{-# INLINE createFromArrayBuffer #-}
45+
46+getArrayBuffer :: SomeBuffer any -> GHCJSPure (SomeArrayBuffer any)
47+getArrayBuffer (SomeBuffer buf) = GHCJSPure $ SomeArrayBuffer <$> buf ^. js "buf"
48+{-# INLINE getArrayBuffer #-}
49+
50+getInt32Array :: SomeBuffer any -> GHCJSPure (I.SomeInt32Array any)
51+getInt32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "i3"
52+{-# INLINE getInt32Array #-}
53+
54+getUint8Array :: SomeBuffer any -> GHCJSPure (I.SomeUint8Array any)
55+getUint8Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u3"
56+{-# INLINE getUint8Array #-}
57+
58+getUint16Array :: SomeBuffer any -> GHCJSPure (I.SomeUint16Array any)
59+getUint16Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "u1"
60+{-# INLINE getUint16Array #-}
61+
62+getFloat32Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat32Array any)
63+getFloat32Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f3"
64+{-# INLINE getFloat32Array #-}
65+
66+getFloat64Array :: SomeBuffer any -> GHCJSPure (I.SomeFloat64Array any)
67+getFloat64Array (SomeBuffer buf) = GHCJSPure $ I.SomeTypedArray <$> buf ^. js "f6"
68+{-# INLINE getFloat64Array #-}
69+
70+getDataView :: SomeBuffer any -> GHCJSPure (SomeDataView any)
71+getDataView (SomeBuffer buf) = GHCJSPure $ SomeDataView <$> buf ^. js "dv"
72+{-# INLINE getDataView #-}
73+
74+freeze :: MutableBuffer -> JSM Buffer
75+freeze = js_clone
76+{-# INLINE freeze #-}
77+
78+thaw :: Buffer -> JSM MutableBuffer
79+thaw = js_clone
80+{-# INLINE thaw #-}
81+
82+clone :: MutableBuffer -> JSM (SomeBuffer any2)
83+clone = js_clone
84+{-# INLINE clone #-}
85+
86+fromByteString :: ByteString -> GHCJSPure (Buffer, Int, Int)
87+fromByteString bs = GHCJSPure $ do
88+ buffer <- SomeBuffer <$> jsg1 "h$newByteArrayBase64String" (decodeUtf8 $ B64.encode bs)
89+ return (buffer, 0, BS.length bs)
90+{-# INLINE fromByteString #-}
91+
92+-- | Wrap a 'Buffer' into a 'ByteString' using the given offset
93+-- and length.
94+toByteString :: Int -> Maybe Int -> Buffer -> GHCJSPure ByteString
95+toByteString off mbLen buf = GHCJSPure $ do
96+ bufLen <- ghcjsPure $ byteLength buf
97+ case mbLen of
98+ _ | off < 0 -> error "toByteString: negative offset"
99+ | off > bufLen -> error "toByteString: offset past end of buffer"
100+ Just len | len < 0 -> error "toByteString: negative length"
101+ | len > bufLen - off -> error "toByteString: length past end of buffer"
102+ | otherwise -> ghcjsPure $ unsafeToByteString off len buf
103+ Nothing -> ghcjsPure $ unsafeToByteString off (bufLen - off) buf
104+
105+unsafeToByteString :: Int -> Int -> Buffer -> GHCJSPure ByteString
106+unsafeToByteString off len (SomeBuffer buf) = GHCJSPure $ do
107+ b64 <- jsg3 "h$byteArrayToBase64String" off len buf >>= fromJSValUnchecked
108+ return $ case B64.decode (encodeUtf8 b64) of
109+ Left err -> error $ "unsafeToByteString base 64 decode error :" ++ err
110+ Right bs -> bs
111+
112+byteLength :: SomeBuffer any -> GHCJSPure Int
113+byteLength (SomeBuffer buf) = GHCJSPure $ buf ^. js "len" >>= fromJSValUnchecked
114+{-# INLINE byteLength #-}
115+
116+js_clone :: SomeBuffer any1 -> JSM (SomeBuffer any2)
117+js_clone (SomeBuffer buf) = SomeBuffer <$> jsg1 "h$wrapBuffer" (buf ^. js "buf" ^. js2 "slice" (buf ^. js "u8" ^. js "byteOffset") (buf ^. js "len"))
jsaddle/src-ghc/GHCJS/Buffer/Types.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
2+
3+module GHCJS.Buffer.Types where
4+
5+import GHCJS.Types
6+import GHCJS.Internal.Types
7+
8+newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer JSVal
9+
10+type Buffer = SomeBuffer Immutable
11+type MutableBuffer = SomeBuffer Mutable
jsaddle/src-ghc/GHCJS/Foreign.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE CPP #-}
2+-----------------------------------------------------------------------------
3+--
4+-- Module : Language.Javascript.JSaddle.Value
5+-- Copyright : (c) Hamish Mackenzie
6+-- License : MIT
7+--
8+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9+--
10+-- |
11+--
12+-----------------------------------------------------------------------------
13+module GHCJS.Foreign (
14+ jsTrue
15+ , jsFalse
16+ , jsNull
17+ , toJSBool
18+-- , fromJSBool
19+ , jsUndefined
20+ , isTruthy
21+ , isNull
22+ , isUndefined
23+ , isObject
24+ , isFunction
25+ , isString
26+ , isBoolean
27+ , isSymbol
28+ , isNumber
29+ , JSType(..)
30+ , jsTypeOf
31+) where
32+
33+import GHCJS.Foreign.Internal
34+import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..))
35+import Language.Javascript.JSaddle.Object (jsg1)
36+import GHCJS.Marshal (FromJSVal(..))
37+
38+isObject :: JSVal -> GHCJSPure Bool
39+isObject v = GHCJSPure $ jsg1 "h$isObject" v >>= fromJSValUnchecked
40+{-# INLINE isObject #-}
41+
42+isFunction :: JSVal -> GHCJSPure Bool
43+isFunction v = GHCJSPure $ jsg1 "h$isFunction" v >>= fromJSValUnchecked
44+{-# INLINE isFunction #-}
45+
46+isString :: JSVal -> GHCJSPure Bool
47+isString v = GHCJSPure $ jsg1 "h$isString" v >>= fromJSValUnchecked
48+{-# INLINE isString #-}
49+
50+isBoolean :: JSVal -> GHCJSPure Bool
51+isBoolean v = GHCJSPure $ jsg1 "h$isBoolean" v >>= fromJSValUnchecked
52+{-# INLINE isBoolean #-}
53+
54+isSymbol :: JSVal -> GHCJSPure Bool
55+isSymbol v = GHCJSPure $ jsg1 "h$isSymbol" v >>= fromJSValUnchecked
56+{-# INLINE isSymbol #-}
57+
58+isNumber :: JSVal -> GHCJSPure Bool
59+isNumber v = GHCJSPure $ jsg1 "h$isNumber" v >>= fromJSValUnchecked
60+{-# INLINE isNumber #-}
61+
62+jsTypeOf :: JSVal -> GHCJSPure JSType
63+jsTypeOf v = GHCJSPure $ toEnum <$> (jsg1 "h$jsonTypeOf" v >>= fromJSValUnchecked)
64+{-# INLINE jsTypeOf #-}
jsaddle/src-ghc/GHCJS/Foreign/Internal.hsnew file+65
@@ -0,0 +1,65 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.Javascript.JSaddle.Value
4+-- Copyright : (c) Hamish Mackenzie
5+-- License : MIT
6+--
7+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8+--
9+-- |
10+--
11+-----------------------------------------------------------------------------
12+module GHCJS.Foreign.Internal (
13+ jsTrue
14+ , jsFalse
15+ , jsNull
16+ , toJSBool
17+-- , fromJSBool
18+ , jsUndefined
19+ , isTruthy
20+ , isNull
21+ , isUndefined
22+ , JSType(..)
23+) where
24+
25+import Language.Javascript.JSaddle.Types (JSVal(..), GHCJSPure(..))
26+import Language.Javascript.JSaddle.Native.Internal
27+ (valueToBool)
28+import Data.Typeable (Typeable)
29+import GHCJS.Prim (isNull, isUndefined)
30+
31+jsTrue :: JSVal
32+jsTrue = JSVal 3
33+{-# INLINE jsTrue #-}
34+
35+jsFalse :: JSVal
36+jsFalse = JSVal 2
37+{-# INLINE jsFalse #-}
38+
39+jsNull :: JSVal
40+jsNull = JSVal 0
41+{-# INLINE jsNull #-}
42+
43+toJSBool :: Bool -> JSVal
44+toJSBool b = JSVal $ if b then 3 else 2
45+{-# INLINE toJSBool #-}
46+
47+jsUndefined :: JSVal
48+jsUndefined = JSVal 1
49+{-# INLINE jsUndefined #-}
50+
51+isTruthy :: JSVal -> GHCJSPure Bool
52+isTruthy = GHCJSPure . valueToBool
53+{-# INLINE isTruthy #-}
54+
55+-- types returned by JS typeof operator
56+data JSType = Undefined
57+ | Object
58+ | Boolean
59+ | Number
60+ | String
61+ | Symbol
62+ | Function
63+ | Other -- ^ implementation dependent
64+ deriving (Show, Eq, Ord, Enum, Typeable)
65+
jsaddle/src-ghc/GHCJS/Internal/Types.hsnew file+16
@@ -0,0 +1,16 @@
1+module GHCJS.Internal.Types ( IsJSVal(..)
2+ , jsval
3+ , MutabilityType(..)
4+ , Mutable
5+ , Immutable
6+ , IsItMutable(..)
7+ , Mutability
8+ ) where
9+
10+import Language.Javascript.JSaddle.Types
11+import Language.Javascript.JSaddle.Native.Internal (stringToValue)
12+
13+instance IsJSVal JSString where
14+ jsval_ a = GHCJSPure $ stringToValue a
15+ {-# INLINE jsval_ #-}
16+
jsaddle/src-ghc/GHCJS/Marshal.hs+37−36
@@ -17,19 +17,23 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
17
17
18import qualified Data.Aeson as AE
18import qualified Data.Aeson as AE
19import Data.Int (Int8, Int16, Int32)
19import Data.Int (Int8, Int16, Int32)
20+import Data.Text (Text)
20import Data.Word (Word8, Word16, Word32, Word)
21import Data.Word (Word8, Word16, Word32, Word)
21
22
22import GHC.Prim
23import GHC.Prim
23
24
24−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), Command(ValueToJSONValue), Result(ValueToJSONValueResult))
25+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), ghcjsPure)
25−import Language.Javascript.JSaddle.Native (withToJSVal)
26+import Language.Javascript.JSaddle.Native.Internal
26−import Language.Javascript.JSaddle.Run(sendCommand)
27+ (valueToJSONValue, jsonValueToValue, valueToNumber)
28+
29+import GHCJS.Types (JSString, isUndefined, isNull)
27−import GHCJS.Marshal.Internal
30+import GHCJS.Foreign.Internal (isTruthy)
28import GHCJS.Marshal.Pure ()
31import GHCJS.Marshal.Pure ()
29−import Language.Javascript.JSaddle.Value (isUndefinedIO, valToNumber,
32+
30− valToBool, valMakeJSON)
31−import Language.Javascript.JSaddle.Array (fromListIO)
33+import JavaScript.Array (fromListIO)
32−import qualified Language.Javascript.JSaddle.Array as A (read)
34+import qualified JavaScript.Array as A (read)
35+
36+import GHCJS.Marshal.Internal
33
37
34instance FromJSVal JSVal where
38instance FromJSVal JSVal where
35 fromJSValUnchecked x = return x
39 fromJSValUnchecked x = return x
@@ -42,65 +46,62 @@ instance FromJSVal () where
42 fromJSVal = fromJSVal_pure
46 fromJSVal = fromJSVal_pure
43-- {-# INLINE fromJSVal #-}
47-- {-# INLINE fromJSVal #-}
44instance FromJSVal Bool where
48instance FromJSVal Bool where
45− fromJSValUnchecked = valToBool
49+ fromJSValUnchecked = ghcjsPure . isTruthy
46 {-# INLINE fromJSValUnchecked #-}
50 {-# INLINE fromJSValUnchecked #-}
47− fromJSVal = fmap Just . valToBool
51+ fromJSVal = fmap Just . ghcjsPure . isTruthy
48 {-# INLINE fromJSVal #-}
52 {-# INLINE fromJSVal #-}
49instance FromJSVal Int where
53instance FromJSVal Int where
50− fromJSValUnchecked = fmap round . valToNumber
54+ fromJSValUnchecked = fmap round . valueToNumber
51 {-# INLINE fromJSValUnchecked #-}
55 {-# INLINE fromJSValUnchecked #-}
52− fromJSVal = fmap (Just . round) . valToNumber
56+ fromJSVal = fmap (Just . round) . valueToNumber
53 {-# INLINE fromJSVal #-}
57 {-# INLINE fromJSVal #-}
54instance FromJSVal Int8 where
58instance FromJSVal Int8 where
55− fromJSValUnchecked = fmap round . valToNumber
59+ fromJSValUnchecked = fmap round . valueToNumber
56 {-# INLINE fromJSValUnchecked #-}
60 {-# INLINE fromJSValUnchecked #-}
57− fromJSVal = fmap (Just . round) . valToNumber
61+ fromJSVal = fmap (Just . round) . valueToNumber
58 {-# INLINE fromJSVal #-}
62 {-# INLINE fromJSVal #-}
59instance FromJSVal Int16 where
63instance FromJSVal Int16 where
60− fromJSValUnchecked = fmap round . valToNumber
64+ fromJSValUnchecked = fmap round . valueToNumber
61 {-# INLINE fromJSValUnchecked #-}
65 {-# INLINE fromJSValUnchecked #-}
62− fromJSVal = fmap (Just . round) . valToNumber
66+ fromJSVal = fmap (Just . round) . valueToNumber
63 {-# INLINE fromJSVal #-}
67 {-# INLINE fromJSVal #-}
64instance FromJSVal Int32 where
68instance FromJSVal Int32 where
65− fromJSValUnchecked = fmap round . valToNumber
69+ fromJSValUnchecked = fmap round . valueToNumber
66 {-# INLINE fromJSValUnchecked #-}
70 {-# INLINE fromJSValUnchecked #-}
67− fromJSVal = fmap (Just . round) . valToNumber
71+ fromJSVal = fmap (Just . round) . valueToNumber
68 {-# INLINE fromJSVal #-}
72 {-# INLINE fromJSVal #-}
69instance FromJSVal Word where
73instance FromJSVal Word where
70− fromJSValUnchecked = fmap round . valToNumber
74+ fromJSValUnchecked = fmap round . valueToNumber
71 {-# INLINE fromJSValUnchecked #-}
75 {-# INLINE fromJSValUnchecked #-}
72− fromJSVal = fmap (Just . round) . valToNumber
76+ fromJSVal = fmap (Just . round) . valueToNumber
73 {-# INLINE fromJSVal #-}
77 {-# INLINE fromJSVal #-}
74instance FromJSVal Word8 where
78instance FromJSVal Word8 where
75− fromJSValUnchecked = fmap round . valToNumber
79+ fromJSValUnchecked = fmap round . valueToNumber
76 {-# INLINE fromJSValUnchecked #-}
80 {-# INLINE fromJSValUnchecked #-}
77− fromJSVal = fmap (Just . round) . valToNumber
81+ fromJSVal = fmap (Just . round) . valueToNumber
78 {-# INLINE fromJSVal #-}
82 {-# INLINE fromJSVal #-}
79instance FromJSVal Word16 where
83instance FromJSVal Word16 where
80− fromJSValUnchecked = fmap round . valToNumber
84+ fromJSValUnchecked = fmap round . valueToNumber
81 {-# INLINE fromJSValUnchecked #-}
85 {-# INLINE fromJSValUnchecked #-}
82− fromJSVal = fmap (Just . round) . valToNumber
86+ fromJSVal = fmap (Just . round) . valueToNumber
83 {-# INLINE fromJSVal #-}
87 {-# INLINE fromJSVal #-}
84instance FromJSVal Word32 where
88instance FromJSVal Word32 where
85− fromJSValUnchecked = fmap round . valToNumber
89+ fromJSValUnchecked = fmap round . valueToNumber
86 {-# INLINE fromJSValUnchecked #-}
90 {-# INLINE fromJSValUnchecked #-}
87− fromJSVal = fmap (Just . round) . valToNumber
91+ fromJSVal = fmap (Just . round) . valueToNumber
88 {-# INLINE fromJSVal #-}
92 {-# INLINE fromJSVal #-}
89instance FromJSVal Float where
93instance FromJSVal Float where
90− fromJSValUnchecked = fmap realToFrac . valToNumber
94+ fromJSValUnchecked = fmap realToFrac . valueToNumber
91 {-# INLINE fromJSValUnchecked #-}
95 {-# INLINE fromJSValUnchecked #-}
92− fromJSVal = fmap (Just . realToFrac) . valToNumber
96+ fromJSVal = fmap (Just . realToFrac) . valueToNumber
93 {-# INLINE fromJSVal #-}
97 {-# INLINE fromJSVal #-}
94instance FromJSVal Double where
98instance FromJSVal Double where
95− fromJSValUnchecked = valToNumber
99+ fromJSValUnchecked = valueToNumber
96 {-# INLINE fromJSValUnchecked #-}
100 {-# INLINE fromJSValUnchecked #-}
97− fromJSVal = fmap Just . valToNumber
101+ fromJSVal = fmap Just . valueToNumber
98 {-# INLINE fromJSVal #-}
102 {-# INLINE fromJSVal #-}
99instance FromJSVal AE.Value where
103instance FromJSVal AE.Value where
100− fromJSVal r =
104+ fromJSVal r = Just <$> valueToJSONValue r
101− withToJSVal r $ \rval -> do
102− ~(ValueToJSONValueResult result) <- sendCommand (ValueToJSONValue rval)
103− return $ Just result
104 {-# INLINE fromJSVal #-}
105 {-# INLINE fromJSVal #-}
105instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
106instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
106 fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
107 fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1
@@ -127,7 +128,7 @@ instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJ
127jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a
128jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a
128jf r n = MaybeT $ do
129jf r n = MaybeT $ do
129 r' <- A.read n (SomeJSArray r)
130 r' <- A.read n (SomeJSArray r)
130− isUndefinedIO r >>= \case
131+ ghcjsPure (isUndefined r) >>= \case
131 True -> return Nothing
132 True -> return Nothing
132 False -> fromJSVal r'
133 False -> fromJSVal r'
133
134
@@ -164,5 +165,5 @@ arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal
164arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]
165arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]
165
166
166toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal
167toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal
167−toJSVal_aeson = valMakeJSON . AE.toJSON
168+toJSVal_aeson = jsonValueToValue . AE.toJSON
168
169
jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+46−31
@@ -3,19 +3,19 @@
3 LambdaCase
3 LambdaCase
4 #-}
4 #-}
5
5
6−module GHCJS.Marshal.Internal (
6+module GHCJS.Marshal.Internal ( FromJSVal(..)
7− FromJSVal(..)
8− , ToJSVal(..)
7+ , ToJSVal(..)
9− , PToJSVal(..)
8+ , PToJSVal(..)
10− , PFromJSVal(..)
9+ , PFromJSVal(..)
11− , Purity(..)
10+ , Purity(..)
12− , toJSVal_generic
11+ , toJSVal_generic
13− , fromJSVal_generic
12+ , fromJSVal_generic
14− , toJSVal_pure
13+ , toJSVal_pure
15− , fromJSVal_pure
14+ , fromJSVal_pure
16− , fromJSValUnchecked_pure
15+ , fromJSValUnchecked_pure
17− ) where
16+ ) where
18−
17+
18+import Control.Applicative
19import Control.Monad
19import Control.Monad
20
20
21import Data.Data
21import Data.Data
@@ -25,11 +25,17 @@ import qualified Data.Text as T (pack)
25
25
26import GHC.Generics
26import GHC.Generics
27
27
28−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, JSString)
28+import qualified GHCJS.Prim.Internal as Prim
29−import Language.Javascript.JSaddle.Foreign (jsNull, jsTrue, isUndefinedIO)
29+import qualified GHCJS.Foreign.Internal as F
30−import Language.Javascript.JSaddle.String (textToStr)
30+import GHCJS.Types
31+
32+import qualified Data.JSString.Internal.Type as JSS
33+
31import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
34import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
32−import qualified JavaScript.Array.Internal as AI (create, push, read, fromListIO, toListIO)
35+import qualified JavaScript.Array.Internal as AI (SomeJSArray(..), create, push, read, fromListIO, toListIO)
36+
37+import Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap)
38+import Language.Javascript.JSaddle.String (textToStr)
33
39
34data Purity = PureShared -- ^ conversion is pure even if the original value is shared
40data Purity = PureShared -- ^ conversion is pure even if the original value is shared
35 | PureExclusive -- ^ conversion is pure if the we only convert once
41 | PureExclusive -- ^ conversion is pure if the we only convert once
@@ -49,6 +55,9 @@ class ToJSVal a where
49 toJSValListOf :: [a] -> JSM JSVal
55 toJSValListOf :: [a] -> JSM JSVal
50 toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal
56 toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal
51
57
58+ -- default toJSVal :: PToJSVal a => a -> JSM (JSVal a)
59+ -- toJSVal x = return (pToJSVal x)
60+
52 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
61 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
53 toJSVal = toJSVal_generic id
62 toJSVal = toJSVal_generic id
54
63
@@ -65,9 +74,15 @@ class FromJSVal a where
65 fromJSValUncheckedListOf :: JSVal -> JSM [a]
74 fromJSValUncheckedListOf :: JSVal -> JSM [a]
66 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
75 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
67
76
77+ -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a)
78+ -- fromJSVal x = return (Just (pFromJSVal x))
79+
68 default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
80 default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
69 fromJSVal = fromJSVal_generic id
81 fromJSVal = fromJSVal_generic id
70
82
83+ -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a
84+ -- fromJSValUnchecked x = return (pFromJSVal x)
85+
71-- -----------------------------------------------------------------------------
86-- -----------------------------------------------------------------------------
72
87
73class GToJSVal a where
88class GToJSVal a where
@@ -92,8 +107,8 @@ instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where
92 gToJSVal f _ (L1 x) = gToJSVal f True x
107 gToJSVal f _ (L1 x) = gToJSVal f True x
93 gToJSVal f _ (R1 x) = gToJSVal f True x
108 gToJSVal f _ (R1 x) = gToJSVal f True x
94
109
95−instance (GToJSVal (a p)) => GToJSVal (M1 D c a p) where
110+instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where
96− gToJSVal f b (M1 x) = gToJSVal f b x
111+ gToJSVal f b m@(M1 x) = gToJSVal f b x
97
112
98instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
113instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
99 gToJSVal f True m@(M1 x) = do
114 gToJSVal f True m@(M1 x) = do
@@ -109,7 +124,7 @@ instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => G
109 gToJSProp f obj' xy
124 gToJSProp f obj' xy
110 return obj'
125 return obj'
111 gToJSVal f False xy = do
126 gToJSVal f False xy = do
112− arr@(SomeJSArray arr') <- AI.create
127+ arr@(AI.SomeJSArray arr') <- AI.create
113 gToJSArr f arr xy
128 gToJSArr f arr xy
114 return arr'
129 return arr'
115
130
@@ -133,10 +148,10 @@ instance GToJSVal (a p) => GToJSArr (M1 S c a p) where
133 AI.push r a
148 AI.push r a
134
149
135instance GToJSVal (V1 p) where
150instance GToJSVal (V1 p) where
136− gToJSVal _ _ _ = return jsNull
151+ gToJSVal _ _ _ = return Prim.jsNull
137
152
138instance GToJSVal (U1 p) where
153instance GToJSVal (U1 p) where
139− gToJSVal _ _ _ = return jsTrue
154+ gToJSVal _ _ _ = return F.jsTrue
140
155
141toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
156toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
142 => (String -> String) -> a -> JSM JSVal
157 => (String -> String) -> a -> JSM JSVal
@@ -163,26 +178,26 @@ instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where
163 gFromJSVal f b r = gFromJSVal f b r
178 gFromJSVal f b r = gFromJSVal f b r
164
179
165instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
180instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
166− gFromJSVal f _b r = do
181+ gFromJSVal f b r = do
167 l <- gFromJSVal f True r
182 l <- gFromJSVal f True r
168 case l of
183 case l of
169 Just x -> return (L1 <$> Just x)
184 Just x -> return (L1 <$> Just x)
170 Nothing -> fmap R1 <$> gFromJSVal f True r
185 Nothing -> fmap R1 <$> gFromJSVal f True r
171
186
172−instance GFromJSVal (a p) => GFromJSVal (M1 D c a p) where
187+instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where
173 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
188 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
174
189
175instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
190instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
176 gFromJSVal f True r = do
191 gFromJSVal f True r = do
177 r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
192 r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
178− isUndefinedIO r' >>= \case
193+ ghcjsPure (isUndefined r') >>= \case
179 True -> return Nothing
194 True -> return Nothing
180 False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'
195 False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'
181 gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r
196 gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r
182
197
183instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
198instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
184 gFromJSVal f True r = gFromJSProp f r
199 gFromJSVal f True r = gFromJSProp f r
185− gFromJSVal f False r = fmap fst <$> gFromJSArr f (SomeJSArray r) 0
200+ gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0
186
201
187instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
202instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
188 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
203 gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r
@@ -197,7 +212,7 @@ instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) whe
197instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
212instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
198 gFromJSProp f o = do
213 gFromJSProp f o = do
199 p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
214 p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
200− isUndefinedIO p >>= \case
215+ ghcjsPure (isUndefined p) >>= \case
201 True -> return Nothing
216 True -> return Nothing
202 False -> fmap M1 <$> gFromJSVal f False p
217 False -> fmap M1 <$> gFromJSVal f False p
203
218
@@ -214,7 +229,7 @@ instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where
214instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
229instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
215 gFromJSArr f o n = do
230 gFromJSArr f o n = do
216 r <- AI.read n o
231 r <- AI.read n o
217− isUndefinedIO r >>= \case
232+ ghcjsPure (isUndefined r) >>= \case
218 True -> return Nothing
233 True -> return Nothing
219 False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r
234 False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r
220
235
@@ -231,15 +246,15 @@ fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: JSM (Maybe (Rep a (
231-- -----------------------------------------------------------------------------
246-- -----------------------------------------------------------------------------
232
247
233fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
248fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
234−fromJSVal_pure x = return (Just (pFromJSVal x))
249+fromJSVal_pure = return . Just . pFromJSVal
235{-# INLINE fromJSVal_pure #-}
250{-# INLINE fromJSVal_pure #-}
236
251
237fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
252fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
238−fromJSValUnchecked_pure x = return (pFromJSVal x)
253+fromJSValUnchecked_pure = return . pFromJSVal
239{-# INLINE fromJSValUnchecked_pure #-}
254{-# INLINE fromJSValUnchecked_pure #-}
240
255
241toJSVal_pure :: PToJSVal a => a -> JSM JSVal
256toJSVal_pure :: PToJSVal a => a -> JSM JSVal
242−toJSVal_pure x = return (pToJSVal x)
257+toJSVal_pure = return . pToJSVal
243{-# INLINE toJSVal_pure #-}
258{-# INLINE toJSVal_pure #-}
244
259
245-- -----------------------------------------------------------------------------
260-- -----------------------------------------------------------------------------
jsaddle/src-ghc/GHCJS/Marshal/Pure.hs+5−6
@@ -1,12 +1,11 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module GHCJS.Marshal.Pure
2+module GHCJS.Marshal.Pure ( PFromJSVal(..)
3− ( PFromJSVal(..)
4− , PToJSVal(..)
3+ , PToJSVal(..)
5− ) where
4+ ) where
6
5
6+import GHCJS.Types
7+import GHCJS.Foreign.Internal (jsFalse, jsTrue)
7import GHCJS.Marshal.Internal
8import GHCJS.Marshal.Internal
8−import Language.Javascript.JSaddle.Types (JSVal(..))
9−import Language.Javascript.JSaddle.Foreign (jsFalse, jsTrue)
10
9
11instance PFromJSVal JSVal where pFromJSVal = id
10instance PFromJSVal JSVal where pFromJSVal = id
12 {-# INLINE pFromJSVal #-}
11 {-# INLINE pFromJSVal #-}
jsaddle/src-ghc/GHCJS/Prim.hsnew file+85
@@ -0,0 +1,85 @@
1+{-# LANGUAGE MagicHash #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5+module GHCJS.Prim ( module GHCJS.Prim.Internal
6+ , fromJSString
7+ , toJSString
8+ , isNull
9+ , isUndefined
10+ , jsNull
11+ ) where
12+
13+import GHCJS.Prim.Internal
14+import Data.Int (Int64)
15+import Data.Typeable (Typeable)
16+import Unsafe.Coerce (unsafeCoerce)
17+
18+import Data.Aeson (ToJSON(..), FromJSON(..))
19+import qualified Data.Text as T (unpack, pack)
20+import Data.JSString.Text (textFromJSVal)
21+
22+import GHC.Prim
23+import qualified GHC.Exception as Ex
24+import qualified GHC.Exts as Exts
25+
26+import Language.Javascript.JSaddle.Types (JSVal(..), JSString(..), GHCJSPure(..), ghcjsPureMap)
27+import qualified Language.Javascript.JSaddle.Native.Internal as N
28+ (stringToValue, isNull, isUndefined)
29+{- | Low-level conversion utilities for packages that cannot
30+ depend on ghcjs-base
31+ -}
32+
33+fromJSString :: JSVal -> GHCJSPure String
34+fromJSString = ghcjsPureMap T.unpack . textFromJSVal
35+{-# INLINE fromJSString #-}
36+
37+toJSString :: String -> GHCJSPure JSVal
38+toJSString s = GHCJSPure $ N.stringToValue (JSString $ T.pack s)
39+{-# INLINE toJSString #-}
40+
41+--fromJSArray :: JSVal -> IO [JSVal]
42+--fromJSArray = unsafeCoerce . js_fromJSArray
43+--{-# INLINE fromJSArray #-}
44+--
45+--toJSArray :: [JSVal] -> IO JSVal
46+--toJSArray = js_toJSArray . unsafeCoerce . seqList
47+--{-# INLINE toJSArray #-}
48+--
49+--{- | returns zero if the JSVal does not contain a number
50+-- -}
51+--fromJSInt :: JSVal -> Int
52+--fromJSInt = js_fromJSInt
53+--{-# INLINE fromJSInt #-}
54+--
55+--toJSInt :: Int -> JSVal
56+--toJSInt = js_toJSInt
57+--{-# INLINE toJSInt #-}
58+--
59+
60+isNull :: JSVal -> GHCJSPure Bool
61+isNull = GHCJSPure . N.isNull
62+{-# INLINE isNull #-}
63+
64+isUndefined :: JSVal -> GHCJSPure Bool
65+isUndefined = GHCJSPure . N.isUndefined
66+{-# INLINE isUndefined #-}
67+
68+--getProp :: JSVal -> String -> IO JSVal
69+--getProp o p = js_getProp o (unsafeCoerce $ seqList p)
70+--{-# INLINE getProp #-}
71+--
72+--getProp' :: JSVal -> JSVal -> IO JSVal
73+--getProp' o p = js_getProp' o p
74+--{-# INLINE getProp' #-}
75+--
76+---- reduce the spine and all list elements to whnf
77+--seqList :: [a] -> [a]
78+--seqList xs = go xs `seq` xs
79+-- where go (x:xs) = x `seq` go xs
80+-- go [] = ()
81+--
82+--seqListSpine :: [a] -> [a]
83+--seqListSpine xs = go xs `seq` xs
84+-- where go (x:xs) = go xs
85+-- go [] = ()
jsaddle/src-ghc/GHCJS/Prim/Internal.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
4+module GHCJS.Prim.Internal ( JSVal(..)
5+ , JSValueRef
6+ , JSException(..)
7+ , WouldBlockException(..)
8+ , mkJSException
9+ , jsNull
10+ ) where
11+
12+import Data.Int (Int64)
13+import Data.Typeable (Typeable)
14+import Unsafe.Coerce (unsafeCoerce)
15+
16+import Data.Aeson (ToJSON(..), FromJSON(..))
17+
18+import qualified GHC.Exception as Ex
19+
20+-- A reference to a particular JavaScript value inside the JavaScript context
21+type JSValueRef = Int64
22+
23+{-
24+ JSVal is a boxed type that can be used as FFI
25+ argument or result.
26+-}
27+newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)
28+
29+{-
30+ When a JavaScript exception is raised inside
31+ a safe or interruptible foreign call, it is converted
32+ to a JSException
33+ -}
34+data JSException = JSException JSVal String
35+ deriving (Typeable)
36+
37+instance Ex.Exception JSException
38+
39+instance Show JSException where
40+ show (JSException _ xs) = "JavaScript exception: " ++ xs
41+
42+mkJSException :: JSVal -> IO JSException
43+mkJSException ref =
44+ return (JSException (unsafeCoerce ref) "")
45+
46+jsNull :: JSVal
47+jsNull = JSVal 0
48+{-# INLINE jsNull #-}
49+
50+{- | If a synchronous thread tries to do something that can only
51+ be done asynchronously, and the thread is set up to not
52+ continue asynchronously, it receives this exception.
53+ -}
54+data WouldBlockException = WouldBlockException
55+ deriving (Typeable)
56+
57+instance Show WouldBlockException where
58+ show _ = "thread would block"
59+
60+instance Ex.Exception WouldBlockException
61+
jsaddle/src-ghc/GHCJS/Types.hsnew file+58
@@ -0,0 +1,58 @@
1+{-# LANGUAGE EmptyDataDecls #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE BangPatterns #-}
4+
5+module GHCJS.Types ( JSVal
6+ , WouldBlockException(..)
7+ , JSException(..)
8+ , IsJSVal
9+ , jsval
10+ , isNull
11+ , isUndefined
12+ , nullRef
13+ , JSString
14+ , mkRef
15+ , Ref#
16+-- , toPtr
17+-- , fromPtr
18+ , JSRef
19+ ) where
20+
21+import Data.JSString.Internal.Type (JSString)
22+import GHCJS.Internal.Types
23+
24+import GHCJS.Prim
25+
26+import GHC.Int
27+import GHC.Types
28+import GHC.Prim
29+import GHC.Ptr
30+
31+import Control.DeepSeq
32+import Unsafe.Coerce
33+
34+type Ref# = Int64
35+
36+mkRef :: Ref# -> JSVal
37+mkRef = JSVal
38+{-# INLINE mkRef #-}
39+
40+nullRef :: JSVal
41+nullRef = JSVal 0
42+{-# INLINE nullRef #-}
43+
44+--toPtr :: JSVal -> Ptr a
45+--toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#)
46+--{-# INLINE toPtr #-}
47+--
48+--fromPtr :: Ptr a -> JSVal
49+--fromPtr p = js_ptrVal p
50+--{-# INLINE fromPtr #-}
51+--
52+--data Ptr' a = Ptr' ByteArray# Int#
53+
54+-- | This is a deprecated copmatibility wrapper for the old JSRef type.
55+--
56+-- See https://github.com/ghcjs/ghcjs/issues/421
57+type JSRef a = JSVal
58+{-# DEPRECATED JSRef "Use JSVal instead, or a more specific newtype wrapper of JSVal " #-}
jsaddle/src/Language/Javascript/JSaddle/Array.hs → jsaddle/src-ghc/JavaScript/Array.hsrenamed+34−21
@@ -1,17 +1,6 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE TypeSynonymInstances #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE Rank2Types #-}
6−#ifdef ghcjs_HOST_OS
7−{-# LANGUAGE ForeignFunctionInterface #-}
8−{-# LANGUAGE JavaScriptFFI #-}
9−{-# OPTIONS_GHC -Wno-dodgy-exports -Wno-dodgy-imports #-}
10−#endif
11−{-# OPTIONS_GHC -fno-warn-orphans #-}
12-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
13--
2--
14−-- Module : Language.Javascript.JSaddle.Object
3+-- Module : JavaScript.Array
15-- Copyright : (c) Hamish Mackenzie
4-- Copyright : (c) Hamish Mackenzie
16-- License : MIT
5-- License : MIT
17--
6--
@@ -20,17 +9,19 @@
20-- | Interface to JavaScript array
9-- | Interface to JavaScript array
21--
10--
22-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
23−
12+module JavaScript.Array
24−module Language.Javascript.JSaddle.Array
25 ( SomeJSArray(..)
13 ( SomeJSArray(..)
26 , JSArray
14 , JSArray
27 , MutableJSArray
15 , MutableJSArray
28 , create
16 , create
29 , length
17 , length
30 , lengthIO
18 , lengthIO
31− , nullIO
19+ , null
20+ , fromList
32 , fromListIO
21 , fromListIO
22+ , toList
33 , toListIO
23 , toListIO
24+ , index, (!)
34 , read
25 , read
35 , write
26 , write
36 , append
27 , append
@@ -39,8 +30,11 @@ module Language.Javascript.JSaddle.Array
39 , unshift
30 , unshift
40 , shift
31 , shift
41 , reverse
32 , reverse
33+ , take
42 , takeIO
34 , takeIO
35+ , drop
43 , dropIO
36 , dropIO
37+ , slice
44 , sliceIO
38 , sliceIO
45 , freeze
39 , freeze
46 , unsafeFreeze
40 , unsafeFreeze
@@ -48,23 +42,27 @@ module Language.Javascript.JSaddle.Array
48 , unsafeThaw
42 , unsafeThaw
49 ) where
43 ) where
50
44
51−import Prelude hiding (read, reverse, null)
45+import Prelude hiding (length, drop, read, take, reverse, null)
52import Control.Monad (void)
46import Control.Monad (void)
53import Language.Javascript.JSaddle.Types
47import Language.Javascript.JSaddle.Types
54 (JSM, JSVal, SomeJSArray(..), JSArray,
48 (JSM, JSVal, SomeJSArray(..), JSArray,
55− MutableJSArray)
49+ MutableJSArray, GHCJSPure(..))
56import Control.Lens.Operators ((^.))
50import Control.Lens.Operators ((^.))
57import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)
51import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)
58import Language.Javascript.JSaddle.Value (valToNumber)
52import Language.Javascript.JSaddle.Value (valToNumber)
59−import JavaScript.Array.Internal (create, fromListIO, toListIO, read, push)
53+import JavaScript.Array.Internal (create, fromList, fromListIO, toList, toListIO, index, read, push)
54+
55+length :: SomeJSArray m -> GHCJSPure Int
56+length = GHCJSPure . lengthIO
57+{-# INLINE length #-}
60
58
61lengthIO :: SomeJSArray m -> JSM Int
59lengthIO :: SomeJSArray m -> JSM Int
62lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)
60lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)
63{-# INLINE lengthIO #-}
61{-# INLINE lengthIO #-}
64
62
65−nullIO :: SomeJSArray m -> JSM Bool
63+null :: SomeJSArray m -> GHCJSPure Bool
66−nullIO = fmap (== 0) . lengthIO
64+null = GHCJSPure . fmap (== 0) . lengthIO
67−{-# INLINE nullIO #-}
65+{-# INLINE null #-}
68
66
69append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)
67append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)
70append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y
68append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y
@@ -90,14 +88,26 @@ reverse :: MutableJSArray -> JSM ()
90reverse (SomeJSArray x) = void $ x ^. js0 "reverse"
88reverse (SomeJSArray x) = void $ x ^. js0 "reverse"
91{-# INLINE reverse #-}
89{-# INLINE reverse #-}
92
90
91+take :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
92+take n = GHCJSPure . takeIO n
93+{-# INLINE take #-}
94+
93takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
95takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
94takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n
96takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n
95{-# INLINE takeIO #-}
97{-# INLINE takeIO #-}
96
98
99+drop :: Int -> SomeJSArray m -> GHCJSPure (SomeJSArray m1)
100+drop n = GHCJSPure . dropIO n
101+{-# INLINE drop #-}
102+
97dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
103dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)
98dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n
104dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n
99{-# INLINE dropIO #-}
105{-# INLINE dropIO #-}
100
106
107+slice :: Int -> Int -> JSArray -> GHCJSPure (SomeJSArray m1)
108+slice s n = GHCJSPure . sliceIO s n
109+{-# INLINE slice #-}
110+
101sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)
111sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)
102sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n
112sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n
103{-# INLINE sliceIO #-}
113{-# INLINE sliceIO #-}
@@ -118,4 +128,7 @@ unsafeThaw :: JSArray -> JSM MutableJSArray
118unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)
128unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)
119{-# INLINE unsafeThaw #-}
129{-# INLINE unsafeThaw #-}
120
130
131+(!) :: JSArray -> Int -> GHCJSPure JSVal
132+x ! n = GHCJSPure $ read n x
133+{-# INLINE (!) #-}
121
134
jsaddle/src-ghc/JavaScript/Array/Internal.hs+33−18
@@ -1,46 +1,61 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module JavaScript.Array.Internal
2module JavaScript.Array.Internal
3+ ( SomeJSArray(..)
4+ , JSArray
5+ , MutableJSArray
6+ , STJSArray
3− ( create
7+ , create
8+ , fromList
4 , fromListIO
9 , fromListIO
10+ , toList
5 , toListIO
11 , toListIO
12+ , index
6 , read
13 , read
7 , push
14 , push
8 ) where
15 ) where
9
16
10import Prelude hiding(read)
17import Prelude hiding(read)
11import Control.Monad (void)
18import Control.Monad (void)
19+import GHCJS.Types (JSVal)
20+import Data.JSString.Internal.Type (JSString(..))
12−import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, Object(..), JSString(..))
21+import Language.Javascript.JSaddle.Types (JSM, SomeJSArray(..), JSArray, MutableJSArray, STJSArray, Object(..), GHCJSPure(..))
13import Language.Javascript.JSaddle.Native.Internal
22import Language.Javascript.JSaddle.Native.Internal
14− (withObject, withJSVal, withJSString, withJSVals)
23+ (newArray, getPropertyByName, getPropertyAtIndex, callAsFunction, valueToNumber)
15import Language.Javascript.JSaddle.Run
24import Language.Javascript.JSaddle.Run
16 (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand)
25 (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand)
17
26
18create :: JSM MutableJSArray
27create :: JSM MutableJSArray
19−create = SomeJSArray <$> sendLazyCommand (NewArray [])
28+create = SomeJSArray <$> newArray []
20{-# INLINE create #-}
29{-# INLINE create #-}
21
30
31+fromList :: [JSVal] -> GHCJSPure (SomeJSArray m)
32+fromList = GHCJSPure . fromListIO
33+{-# INLINE fromList #-}
34+
22fromListIO :: [JSVal] -> JSM (SomeJSArray m)
35fromListIO :: [JSVal] -> JSM (SomeJSArray m)
23−fromListIO xs = withJSVals xs $ \xs' -> SomeJSArray <$> sendLazyCommand (NewArray xs')
36+fromListIO xs = SomeJSArray <$> newArray xs
24{-# INLINE fromListIO #-}
37{-# INLINE fromListIO #-}
25
38
39+toList :: SomeJSArray m -> GHCJSPure [JSVal]
40+toList = GHCJSPure . toListIO
41+{-# INLINE toList #-}
42+
26toListIO :: SomeJSArray m -> JSM [JSVal]
43toListIO :: SomeJSArray m -> JSM [JSVal]
27−toListIO (SomeJSArray x) =
44+toListIO (SomeJSArray x) = do
28− withObject (Object x) $ \this -> do
45+ len <- getPropertyByName (JSString "length") (Object x) >>= valueToNumber
29− l <- withJSString (JSString "length") $ sendLazyCommand . GetPropertyByName this
46+ mapM (`getPropertyAtIndex` Object x) [0..round len - 1]
30− withJSVal l $ \l' -> do
31− ~(ValueToNumberResult len) <- sendCommand (ValueToNumber l')
32− mapM (sendLazyCommand . GetPropertyAtIndex this) [0..round len - 1]
33{-# INLINE toListIO #-}
47{-# INLINE toListIO #-}
34
48
49+index :: Int -> SomeJSArray m -> GHCJSPure JSVal
50+index n = GHCJSPure . read n
51+{-# INLINE index #-}
52+
35read :: Int -> SomeJSArray m -> JSM JSVal
53read :: Int -> SomeJSArray m -> JSM JSVal
36−read n (SomeJSArray x) =
54+read n (SomeJSArray x) = getPropertyAtIndex n $ Object x
37− withObject (Object x) $ \this -> sendLazyCommand $ GetPropertyAtIndex this n
38{-# INLINE read #-}
55{-# INLINE read #-}
39
56
40push :: JSVal -> MutableJSArray -> JSM ()
57push :: JSVal -> MutableJSArray -> JSM ()
41−push e (SomeJSArray x) =
58+push e (SomeJSArray x) = void $ do
42− void $ withJSVal e $ \e' ->
59+ f <- getPropertyByName (JSString "push") (Object x)
43− withObject (Object x) $ \this -> do
60+ void $ callAsFunction (Object f) (Object x) [e]
44− f <- withJSString (JSString "push") $ sendLazyCommand . GetPropertyByName this
45− withObject (Object f) $ \f' -> sendLazyCommand $ CallAsFunction f' this [e']
46{-# INLINE push #-}
61{-# INLINE push #-}
jsaddle/src-ghc/JavaScript/Object.hsnew file+10
@@ -0,0 +1,10 @@
1+module JavaScript.Object ( Object
2+ , create
3+ , getProp, unsafeGetProp
4+ , setProp, unsafeSetProp
5+ -- , allProps
6+ , listProps
7+ -- , isInstanceOf
8+ ) where
9+
10+import JavaScript.Object.Internal
jsaddle/src-ghc/JavaScript/Object/Internal.hs+26−22
@@ -7,43 +7,47 @@ module JavaScript.Object.Internal
7 , unsafeGetProp
7 , unsafeGetProp
8 , setProp
8 , setProp
9 , unsafeSetProp
9 , unsafeSetProp
10−-- , isInstanceOfIO
10+-- , isInstanceOf
11 ) where
11 ) where
12
12
13import Language.Javascript.JSaddle.Types (JSM, JSVal, Object(..), JSString)
13import Language.Javascript.JSaddle.Types (JSM, JSVal, Object(..), JSString)
14import Language.Javascript.JSaddle.Native.Internal
14import Language.Javascript.JSaddle.Native.Internal
15− (withObject, withJSString, withJSVal, wrapJSString)
15+ (newEmptyObject, propertyNames, getPropertyByName, setPropertyByName)
16−import Language.Javascript.JSaddle.Run
17− (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand, sendAsyncCommand)
18
16
17+-- | create an empty object
19create :: JSM Object
18create :: JSM Object
20−create = Object <$> sendLazyCommand NewEmptyObject
19+create = newEmptyObject
20+{-# INLINE create #-}
21+
22+--allProps :: Object -> JSM JSArray
23+--allProps o = js_allProps o
24+--{-# INLINE allProps #-}
21
25
22listProps :: Object -> JSM [JSString]
26listProps :: Object -> JSM [JSString]
23−listProps this =
27+listProps = propertyNames
24− withObject this $ \rthis -> do
25− ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis
26− mapM wrapJSString result
27{-# INLINE listProps #-}
28{-# INLINE listProps #-}
28
29
29−unsafeGetProp :: JSString -> Object -> JSM JSVal
30+{- | get a property from an object. If accessing the property results in
30−unsafeGetProp name this =
31+ an exception, the exception is converted to a JSException. Since exception
31− withObject this $ \rthis ->
32+ handling code prevents some optimizations in some JS engines, you may want
32− withJSString name $ sendLazyCommand . GetPropertyByName rthis
33−{-# INLINE unsafeGetProp #-}
33+ to use unsafeGetProp instead
34−
34+ -}
35getProp :: JSString -> Object -> JSM JSVal
35getProp :: JSString -> Object -> JSM JSVal
36getProp = unsafeGetProp
36getProp = unsafeGetProp
37{-# INLINE getProp #-}
37{-# INLINE getProp #-}
38
38
39−unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()
39+unsafeGetProp :: JSString -> Object -> JSM JSVal
40−unsafeSetProp name val this =
40+unsafeGetProp = getPropertyByName
41− withObject this $ \rthis ->
41+{-# INLINE unsafeGetProp #-}
42− withJSString name $ \rname ->
43− withJSVal val $ \rval ->
44− sendAsyncCommand $ SetPropertyByName rthis rname rval
45−{-# INLINE unsafeSetProp #-}
46
42
47setProp :: JSString -> JSVal -> Object -> JSM ()
43setProp :: JSString -> JSVal -> Object -> JSM ()
48setProp = unsafeSetProp
44setProp = unsafeSetProp
49{-# INLINE setProp #-}
45{-# INLINE setProp #-}
46+
47+unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()
48+unsafeSetProp = setPropertyByName
49+{-# INLINE unsafeSetProp #-}
50+
51+--isInstanceOf :: Object -> JSVal -> GHCJSPure Bool
52+--isInstanceOf o s = js_isInstanceOf o s
53+--{-# INLINE isInstanceOf #-}
jsaddle/src-ghc/JavaScript/TypedArray.hsnew file+19
@@ -0,0 +1,19 @@
1+module JavaScript.TypedArray
2+ ( TypedArray(..)
3+ , Int8Array, Int16Array, Int32Array
4+ , Uint8Array, Uint16Array, Uint32Array
5+ , Uint8ClampedArray, Float32Array, Float64Array
6+ , length
7+ , byteLength
8+ , byteOffset
9+ , buffer
10+ , subarray
11+ , set
12+ , unsafeSet
13+ ) where
14+
15+import Prelude ()
16+
17+import JavaScript.TypedArray.Internal
18+import JavaScript.TypedArray.Internal.Types
19+
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer.hsnew file+51
@@ -0,0 +1,51 @@
1+module JavaScript.TypedArray.ArrayBuffer
2+ ( ArrayBuffer
3+ , MutableArrayBuffer
4+ , freeze, unsafeFreeze
5+ , thaw, unsafeThaw
6+ , byteLengthIO
7+ ) where
8+
9+import Control.Lens.Operators ((^.))
10+
11+import GHCJS.Marshal (fromJSValUnchecked)
12+
13+import Language.Javascript.JSaddle.Types (JSM)
14+import Language.Javascript.JSaddle.Object (jsg, new, js, js1, js2)
15+import JavaScript.TypedArray.ArrayBuffer.Internal
16+
17+create :: Int -> JSM MutableArrayBuffer
18+create n = SomeArrayBuffer <$> new (jsg "ArrayBuffer") [n]
19+{-# INLINE create #-}
20+
21+{- | Create an immutable 'ArrayBuffer' by copying a 'MutableArrayBuffer' -}
22+freeze :: MutableArrayBuffer -> JSM ArrayBuffer
23+freeze (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int)
24+{-# INLINE freeze #-}
25+
26+{- | Create an immutable 'ArrayBuffer' from a 'MutableArrayBuffer' without
27+ copying. The result shares the buffer with the argument, not modify
28+ the data in the 'MutableArrayBuffer' after freezing
29+ -}
30+unsafeFreeze :: MutableArrayBuffer -> JSM ArrayBuffer
31+unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b)
32+{-# INLINE unsafeFreeze #-}
33+
34+{- | Create a 'MutableArrayBuffer' by copying an immutable 'ArrayBuffer' -}
35+thaw :: ArrayBuffer -> JSM MutableArrayBuffer
36+thaw (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" (0 :: Int)
37+{-# INLINE thaw #-}
38+
39+unsafeThaw :: ArrayBuffer -> JSM MutableArrayBuffer
40+unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b)
41+{-# INLINE unsafeThaw #-}
42+
43+sliceIO :: Int -> Maybe Int -> SomeArrayBuffer any -> JSM (SomeArrayBuffer any)
44+sliceIO begin (Just end) (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js2 "slice" begin end
45+sliceIO begin _ (SomeArrayBuffer b) = SomeArrayBuffer <$> b ^. js1 "slice" begin
46+{-# INLINE sliceIO #-}
47+
48+byteLengthIO :: SomeArrayBuffer any -> JSM Int
49+byteLengthIO (SomeArrayBuffer b) = b ^. js "byteLength" >>= fromJSValUnchecked
50+{-# INLINE byteLengthIO #-}
51+
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Internal.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# LANGUAGE GHCForeignImportPrim #-}
2+{-# LANGUAGE MagicHash #-}
3+{-# LANGUAGE UnboxedTuples #-}
4+{-# LANGUAGE MagicHash #-}
5+{-# LANGUAGE TypeSynonymInstances #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE DataKinds #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE DeriveDataTypeable #-}
10+
11+module JavaScript.TypedArray.ArrayBuffer.Internal where
12+
13+import GHCJS.Types
14+
15+import GHCJS.Internal.Types
16+import GHCJS.Marshal.Pure
17+
18+import GHC.Exts (State#)
19+
20+import Data.Typeable
21+
22+newtype SomeArrayBuffer (a :: MutabilityType s) =
23+ SomeArrayBuffer JSVal deriving Typeable
24+instance IsJSVal (SomeArrayBuffer m)
25+
26+type ArrayBuffer = SomeArrayBuffer Immutable
27+type MutableArrayBuffer = SomeArrayBuffer Mutable
28+type STArrayBuffer s = SomeArrayBuffer (STMutable s)
29+
30+instance PToJSVal MutableArrayBuffer where
31+ pToJSVal (SomeArrayBuffer b) = b
32+instance PFromJSVal MutableArrayBuffer where
33+ pFromJSVal = SomeArrayBuffer
jsaddle/src-ghc/JavaScript/TypedArray/ArrayBuffer/Type.hsnew file+6
@@ -0,0 +1,6 @@
1+module JavaScript.TypedArray.ArrayBuffer.Type where
2+
3+import GHCJS.Prim
4+
5+
6+
jsaddle/src-ghc/JavaScript/TypedArray/DataView/Internal.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE JavaScriptFFI #-}
3+{-# LANGUAGE ForeignFunctionInterface #-}
4+{-# LANGUAGE UnliftedFFITypes #-}
5+{-# LANGUAGE GHCForeignImportPrim #-}
6+{-# LANGUAGE MagicHash #-}
7+{-# LANGUAGE UnboxedTuples #-}
8+{-# LANGUAGE DeriveDataTypeable #-}
9+{-# LANGUAGE DataKinds #-}
10+{-# LANGUAGE KindSignatures #-}
11+{-# LANGUAGE PolyKinds #-}
12+
13+module JavaScript.TypedArray.DataView.Internal where
14+
15+import Data.Int
16+import Data.Typeable
17+import Data.Word
18+
19+import GHC.Exts ( State# )
20+
21+import GHCJS.Prim
22+import GHCJS.Internal.Types
23+
24+import JavaScript.TypedArray.ArrayBuffer.Internal
25+
26+newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSVal
27+ deriving Typeable
28+
29+type DataView = SomeDataView Immutable
30+type MutableDataView = SomeDataView Mutable
31+type STDataView s = SomeDataView (STMutable s)
32+
33+-- #define JSU foreign import javascript unsafe
34+-- #define JSS foreign import javascript safe
35+--
36+--JSU "new DataView($1)"
37+-- js_dataView1 :: JSVal -> JSVal
38+--JSS "new DataView($2,$1)"
39+-- js_dataView2 :: Int -> JSVal -> SomeDataView m
40+--JSU "new DataView($2,$1)"
41+-- js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m
42+--JSS "new DataView($3,$1,$2)"
43+-- js_dataView :: Int -> Int -> JSVal -> SomeDataView m
44+--JSU "new DataView($3,$1,$2)"
45+-- js_unsafeDataView :: Int -> Int -> JSVal -> JSVal
46+--JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))"
47+-- js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1)
48+--
49+---- ----------------------------------------------------------------------------
50+---- immutable getters
51+--
52+--JSU "$2.getInt8($1)" js_i_unsafeGetInt8 :: Int -> DataView -> Int8
53+--JSU "$2.getUint8($1)" js_i_unsafeGetUint8 :: Int -> DataView -> Word8
54+--JSU "$2.getInt16($1)" js_i_unsafeGetInt16BE :: Int -> DataView -> Int16
55+--JSU "$2.getInt32($1)" js_i_unsafeGetInt32BE :: Int -> DataView -> Int
56+--JSU "$2.getUint16($1)" js_i_unsafeGetUint16BE :: Int -> DataView -> Word16
57+--JSU "$2.getUint32($1)|0" js_i_unsafeGetUint32BE :: Int -> DataView -> Word
58+--JSU "$2.getFloat32($1)" js_i_unsafeGetFloat32BE :: Int -> DataView -> Double
59+--JSU "$2.getFloat64($1)" js_i_unsafeGetFloat64BE :: Int -> DataView -> Double
60+--JSU "$2.getInt16($1,true)" js_i_unsafeGetInt16LE :: Int -> DataView -> Int16
61+--JSU "$2.getInt32($1,true)" js_i_unsafeGetInt32LE :: Int -> DataView -> Int
62+--JSU "$2.getUint16($1,true)" js_i_unsafeGetUint16LE :: Int -> DataView -> Word16
63+--JSU "$2.getUint32($1,true)|0" js_i_unsafeGetUint32LE :: Int -> DataView -> Word
64+--JSU "$2.getFloat32($1,true)" js_i_unsafeGetFloat32LE :: Int -> DataView -> Double
65+--JSU "$2.getFloat64($1,true)" js_i_unsafeGetFloat64LE :: Int -> DataView -> Double
66+--
67+--JSS "$2.getInt8($1)" js_i_getInt8 :: Int -> DataView -> Int8
68+--JSS "$2.getUint8($1)" js_i_getUint8 :: Int -> DataView -> Word8
69+--JSS "$2.getInt16($1)" js_i_getInt16BE :: Int -> DataView -> Int16
70+--JSS "$2.getInt32($1)" js_i_getInt32BE :: Int -> DataView -> Int
71+--JSS "$2.getUint16($1)" js_i_getUint16BE :: Int -> DataView -> Word16
72+--JSS "$2.getUint32($1)|0" js_i_getUint32BE :: Int -> DataView -> Word
73+--JSS "$2.getFloat32($1)" js_i_getFloat32BE :: Int -> DataView -> Double
74+--JSS "$2.getFloat64($1)" js_i_getFloat64BE :: Int -> DataView -> Double
75+--JSS "$2.getInt16($1,true)" js_i_getInt16LE :: Int -> DataView -> Int16
76+--JSS "$2.getInt32($1,true)" js_i_getInt32LE :: Int -> DataView -> Int
77+--JSS "$2.getUint16($1,true)" js_i_getUint16LE :: Int -> DataView -> Word16
78+--JSS "$2.getUint32($1,true)|0" js_i_getUint32LE :: Int -> DataView -> Word
79+--JSS "$2.getFloat32($1,true)" js_i_getFloat32LE :: Int -> DataView -> Double
80+--JSS "$2.getFloat64($1,true)" js_i_getFloat64LE :: Int -> DataView -> Double
81+--
82+---- ----------------------------------------------------------------------------
83+---- mutable getters
84+--
85+--JSU "$2.getInt8($1)" js_m_unsafeGetInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)
86+--JSU "$2.getUint8($1)" js_m_unsafeGetUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)
87+--JSU "$2.getInt16($1)" js_m_unsafeGetInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
88+--JSU "$2.getInt32($1)" js_m_unsafeGetInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
89+--JSU "$2.getUint16($1)" js_m_unsafeGetUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
90+--JSU "$2.getUint32($1)|0" js_m_unsafeGetUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
91+--JSU "$2.getFloat32($1)" js_m_unsafeGetFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
92+--JSU "$2.getFloat64($1)" js_m_unsafeGetFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
93+--JSU "$2.getInt16($1,true)" js_m_unsafeGetInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
94+--JSU "$2.getInt32($1,true)" js_m_unsafeGetInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
95+--JSU "$2.getUint16($1,true)" js_m_unsafeGetUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
96+--JSU "$2.getUint32($1,true)|0" js_m_unsafeGetUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
97+--JSU "$2.getFloat32($1,true)" js_m_unsafeGetFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
98+--JSU "$2.getFloat64($1,true)" js_m_unsafeGetFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
99+--
100+--JSS "$2.getInt8($1)" js_m_getInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)
101+--JSS "$2.getUint8($1)" js_m_getUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)
102+--JSS "$2.getInt16($1)" js_m_getInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
103+--JSS "$2.getInt32($1)" js_m_getInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
104+--JSS "$2.getUint16($1)" js_m_getUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
105+--JSS "$2.getUint32($1)|0" js_m_getUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
106+--JSS "$2.getFloat32($1)" js_m_getFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
107+--JSS "$2.getFloat64($1)" js_m_getFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
108+--JSS "$2.getInt16($1,true)" js_m_getInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)
109+--JSS "$2.getInt32($1,true)" js_m_getInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)
110+--JSS "$2.getUint16($1,true)" js_m_getUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)
111+--JSS "$2.getUint32($1,true)|0" js_m_getUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)
112+--JSS "$2.getFloat32($1,true)" js_m_getFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
113+--JSS "$2.getFloat64($1,true)" js_m_getFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)
114+--
115+---- ----------------------------------------------------------------------------
116+---- mutable setters
117+--
118+--JSU "$3.setInt8($1,$2)" js_unsafeSetInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)
119+--JSU "$3.setUint8($1,$2)" js_unsafeSetUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)
120+--JSU "$3.setInt16($1,$2)" js_unsafeSetInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
121+--JSU "$3.setInt32($1,$2)" js_unsafeSetInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
122+--JSU "$3.setUint16($1,$2)" js_unsafeSetUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
123+--JSU "$3.setUint32($1,$2)" js_unsafeSetUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
124+--JSU "$3.setFloat32($1,$2)" js_unsafeSetFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
125+--JSU "$3.setFloat64($1,$2)" js_unsafeSetFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
126+--JSU "$3.setInt16($1,$2,true)" js_unsafeSetInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
127+--JSU "$3.setInt32($1,$2,true)" js_unsafeSetInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
128+--JSU "$3.setUint16($1,$2,true)" js_unsafeSetUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
129+--JSU "$3.setUint32($1,$2,true)" js_unsafeSetUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
130+--JSU "$3.setFloat32($1,$2,true)" js_unsafeSetFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
131+--JSU "$3.setFloat64($1,$2,true)" js_unsafeSetFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
132+--
133+--JSS "$3.setInt8($1,$2)" js_setInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)
134+--JSS "$3.setUint8($1,$2)" js_setUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)
135+--JSS "$3.setInt16($1,$2)" js_setInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
136+--JSS "$3.setInt32($1,$2)" js_setInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
137+--JSS "$3.setUint16($1,$2)" js_setUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
138+--JSS "$3.setUint32($1,$2)" js_setUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
139+--JSS "$3.setFloat32($1,$2)" js_setFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
140+--JSS "$3.setFloat64($1,$2)" js_setFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
141+--JSS "$3.setInt16($1,$2,true)" js_setInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)
142+--JSS "$3.setInt32($1,$2,true)" js_setInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)
143+--JSS "$3.setUint16($1,$2,true)" js_setUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)
144+--JSS "$3.setUint32($1,$2,true)" js_setUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)
145+--JSS "$3.setFloat32($1,$2,true)" js_setFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
146+--JSS "$3.setFloat64($1,$2,true)" js_setFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)
147+
jsaddle/src-ghc/JavaScript/TypedArray/Immutable.hsnew file+1
@@ -0,0 +1 @@
1+module JavaScript.TypedArray.Immutable where
jsaddle/src-ghc/JavaScript/TypedArray/Internal.hsnew file+344
@@ -0,0 +1,344 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE TypeSynonymInstances #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE PolyKinds #-}
6+
7+module JavaScript.TypedArray.Internal where
8+
9+import Prelude hiding ((!!))
10+
11+import GHC.Int
12+import GHC.Word
13+
14+import GHCJS.Internal.Types
15+
16+import Control.Monad (void)
17+import Control.Lens.Operators ((^.))
18+
19+import GHCJS.Marshal (fromJSValUnchecked)
20+
21+import JavaScript.Array.Internal (SomeJSArray(..))
22+import JavaScript.TypedArray.ArrayBuffer
23+import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))
24+import JavaScript.TypedArray.Internal.Types
25+
26+import Language.Javascript.JSaddle.Types (JSM, GHCJSPure(..))
27+import Language.Javascript.JSaddle.Object (js, jsg, js1, js2, new, (!!), (<##))
28+
29+elemSize :: SomeTypedArray e m -> GHCJSPure Int
30+elemSize (SomeTypedArray a) = GHCJSPure $ a ^. js "BYTES_PER_ELEMENT" >>= fromJSValUnchecked
31+{-# INLINE [1] elemSize #-}
32+{-# RULES "elemSizeUint8Clamped" forall (x :: SomeUint8ClampedArray m). elemSize x = GHCJSPure $ return 1 #-}
33+{-# RULES "elemSizeUint8" forall (x :: SomeUint8Array m). elemSize x = GHCJSPure $ return 1 #-}
34+{-# RULES "elemSizeUint16" forall (x :: SomeUint16Array m). elemSize x = GHCJSPure $ return 2 #-}
35+{-# RULES "elemSizeUint32" forall (x :: SomeUint32Array m). elemSize x = GHCJSPure $ return 4 #-}
36+{-# RULES "elemSizeInt8" forall (x :: SomeInt8Array m). elemSize x = GHCJSPure $ return 1 #-}
37+{-# RULES "elemSizeInt16" forall (x :: SomeInt16Array m). elemSize x = GHCJSPure $ return 2 #-}
38+{-# RULES "elemSizeInt32" forall (x :: SomeInt32Array m). elemSize x = GHCJSPure $ return 4 #-}
39+{-# RULES "elemSizeFloat32" forall (x :: SomeFloat32Array m). elemSize x = GHCJSPure $ return 4 #-}
40+{-# RULES "elemSizeFloat64" forall (x :: SomeFloat64Array m). elemSize x = GHCJSPure $ return 8 #-}
41+
42+instance TypedArray IOInt8Array where
43+ index = indexI8
44+ unsafeIndex = unsafeIndexI8
45+ setIndex i x = setIndexI i (fromIntegral x)
46+ unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x)
47+ indexOf s x = indexOfI s (fromIntegral x)
48+ lastIndexOf s x = lastIndexOfI s (fromIntegral x)
49+ create l = SomeTypedArray <$> new (jsg "Int8Array") [l]
50+ fromArray = int8ArrayFrom
51+ fromArrayBuffer = undefined
52+
53+instance TypedArray IOInt16Array where
54+ index = indexI16
55+ unsafeIndex = unsafeIndexI16
56+ setIndex i x = setIndexI i (fromIntegral x)
57+ unsafeSetIndex i x = unsafeSetIndexI i (fromIntegral x)
58+ indexOf s x = indexOfI s (fromIntegral x)
59+ lastIndexOf s x = lastIndexOfI s (fromIntegral x)
60+ create l = SomeTypedArray <$> new (jsg "Int16Array") [l]
61+ fromArray = int16ArrayFrom
62+ fromArrayBuffer = undefined
63+
64+instance TypedArray IOInt32Array where
65+ index = indexI
66+ unsafeIndex = unsafeIndexI
67+ setIndex = setIndexI
68+ unsafeSetIndex = unsafeSetIndexI
69+ indexOf = indexOfI
70+ lastIndexOf = lastIndexOfI
71+ create l = SomeTypedArray <$> new (jsg "Int32Array") [l]
72+ fromArray = int32ArrayFrom
73+ fromArrayBuffer = undefined
74+
75+instance TypedArray IOUint8ClampedArray where
76+ index = indexW8
77+ unsafeIndex = unsafeIndexW8
78+ setIndex i x = setIndexW i (fromIntegral x)
79+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
80+ indexOf s x = indexOfW s (fromIntegral x)
81+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
82+ create l = SomeTypedArray <$> new (jsg "Uint8ClampedArray") [l]
83+ fromArray = uint8ClampedArrayFrom
84+ fromArrayBuffer = undefined
85+
86+instance TypedArray IOUint8Array where
87+ index = indexW8
88+ unsafeIndex = unsafeIndexW8
89+ setIndex i x = setIndexW i (fromIntegral x)
90+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
91+ indexOf s x = indexOfW s (fromIntegral x)
92+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
93+ create l = SomeTypedArray <$> new (jsg "Uint8Array") [l]
94+ fromArray = uint8ArrayFrom
95+ fromArrayBuffer = undefined
96+
97+instance TypedArray IOUint16Array where
98+ index = indexW16
99+ unsafeIndex = unsafeIndexW16
100+ setIndex i x = setIndexW i (fromIntegral x)
101+ unsafeSetIndex i x = unsafeSetIndexW i (fromIntegral x)
102+ indexOf s x = indexOfW s (fromIntegral x)
103+ lastIndexOf s x = lastIndexOfW s (fromIntegral x)
104+ create l = SomeTypedArray <$> new (jsg "Uint16Array") [l]
105+ fromArray = uint16ArrayFrom
106+ fromArrayBuffer = undefined
107+
108+instance TypedArray IOUint32Array where
109+ index = indexW
110+ unsafeIndex = unsafeIndexW
111+ setIndex = setIndexW
112+ unsafeSetIndex = unsafeSetIndexW
113+ indexOf = indexOfW
114+ lastIndexOf = lastIndexOfW
115+ create l = SomeTypedArray <$> new (jsg "Uint32Array") [l]
116+ fromArray = uint32ArrayFrom
117+ fromArrayBuffer = undefined
118+
119+instance TypedArray IOFloat32Array where
120+ index = indexD
121+ unsafeIndex = unsafeIndexD
122+ setIndex = setIndexD
123+ unsafeSetIndex = unsafeSetIndexD
124+ indexOf = indexOfD
125+ lastIndexOf = lastIndexOfD
126+ create l = SomeTypedArray <$> new (jsg "Float32Array") [l]
127+ fromArray = float32ArrayFrom
128+ fromArrayBuffer = undefined
129+
130+instance TypedArray IOFloat64Array where
131+ index = indexD
132+ unsafeIndex = unsafeIndexD
133+ setIndex = setIndexD
134+ unsafeSetIndex = unsafeSetIndexD
135+ indexOf = indexOfD
136+ lastIndexOf = lastIndexOfD
137+ create l = SomeTypedArray <$> new (jsg "Float64Array") [l]
138+ fromArray = float64ArrayFrom
139+ fromArrayBuffer = undefined
140+
141+
142+class TypedArray a where
143+ unsafeIndex :: Int -> a -> JSM (Elem a)
144+ index :: Int -> a -> JSM (Elem a)
145+ unsafeSetIndex :: Int -> Elem a -> a -> JSM ()
146+ setIndex :: Int -> Elem a -> a -> JSM ()
147+ create :: Int -> JSM a
148+ fromArray :: SomeJSArray m -> JSM a
149+ fromArrayBuffer :: MutableArrayBuffer -> Int -> Maybe Int -> JSM a
150+ indexOf :: Int -> Elem a -> a -> JSM Int
151+ lastIndexOf :: Int -> Elem a -> a -> JSM Int
152+
153+-- -----------------------------------------------------------------------------
154+
155+indexI :: Int -> SomeTypedArray e m -> JSM Int
156+indexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
157+{-# INLINE indexI #-}
158+
159+indexI16 :: Int -> SomeTypedArray e m -> JSM Int16
160+indexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
161+{-# INLINE indexI16 #-}
162+
163+indexI8 :: Int -> SomeTypedArray e m -> JSM Int8
164+indexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
165+{-# INLINE indexI8 #-}
166+
167+indexW :: Int -> SomeTypedArray e m -> JSM Word
168+indexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
169+{-# INLINE indexW #-}
170+
171+indexW16 :: Int -> SomeTypedArray e m -> JSM Word16
172+indexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
173+{-# INLINE indexW16 #-}
174+
175+indexW8 :: Int -> SomeTypedArray e m -> JSM Word8
176+indexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
177+{-# INLINE indexW8 #-}
178+
179+indexD :: Int -> SomeTypedArray e m -> JSM Double
180+indexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
181+{-# INLINE indexD #-}
182+
183+-- -----------------------------------------------------------------------------
184+
185+unsafeIndexI :: Int -> SomeTypedArray e m -> JSM Int
186+unsafeIndexI i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
187+{-# INLINE unsafeIndexI #-}
188+
189+unsafeIndexI16 :: Int -> SomeTypedArray e m -> JSM Int16
190+unsafeIndexI16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
191+{-# INLINE unsafeIndexI16 #-}
192+
193+unsafeIndexI8 :: Int -> SomeTypedArray e m -> JSM Int8
194+unsafeIndexI8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
195+{-# INLINE unsafeIndexI8 #-}
196+
197+unsafeIndexW :: Int -> SomeTypedArray e m -> JSM Word
198+unsafeIndexW i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
199+{-# INLINE unsafeIndexW #-}
200+
201+unsafeIndexW16 :: Int -> SomeTypedArray e m -> JSM Word16
202+unsafeIndexW16 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
203+{-# INLINE unsafeIndexW16 #-}
204+
205+unsafeIndexW8 :: Int -> SomeTypedArray e m -> JSM Word8
206+unsafeIndexW8 i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
207+{-# INLINE unsafeIndexW8 #-}
208+
209+unsafeIndexD :: Int -> SomeTypedArray e m -> JSM Double
210+unsafeIndexD i (SomeTypedArray a) = a !! i >>= fromJSValUnchecked
211+{-# INLINE unsafeIndexD #-}
212+
213+-- -----------------------------------------------------------------------------
214+
215+int8ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt8Array m1)
216+int8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int8Array" ^. js1 "from" a
217+{-# INLINE int8ArrayFrom #-}
218+
219+int16ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt16Array m1)
220+int16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int16Array" ^. js1 "from" a
221+{-# INLINE int16ArrayFrom #-}
222+
223+int32ArrayFrom :: SomeJSArray m0 -> JSM (SomeInt32Array m1)
224+int32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Int32Array" ^. js1 "from" a
225+{-# INLINE int32ArrayFrom #-}
226+
227+uint8ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8Array m1)
228+uint8ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8Array" ^. js1 "from" a
229+{-# INLINE uint8ArrayFrom #-}
230+
231+uint8ClampedArrayFrom :: SomeJSArray m0 -> JSM (SomeUint8ClampedArray m1)
232+uint8ClampedArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint8ClampedArray" ^. js1 "from" a
233+{-# INLINE uint8ClampedArrayFrom #-}
234+
235+uint16ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint16Array m1)
236+uint16ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint16Array" ^. js1 "from" a
237+{-# INLINE uint16ArrayFrom #-}
238+
239+uint32ArrayFrom :: SomeJSArray m0 -> JSM (SomeUint32Array m1)
240+uint32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Uint32Array" ^. js1 "from" a
241+{-# INLINE uint32ArrayFrom #-}
242+
243+float32ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat32Array m1)
244+float32ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float32Array" ^. js1 "from" a
245+{-# INLINE float32ArrayFrom #-}
246+
247+float64ArrayFrom :: SomeJSArray m0 -> JSM (SomeFloat64Array m1)
248+float64ArrayFrom (SomeJSArray a) = SomeTypedArray <$> jsg "Float64Array" ^. js1 "from" a
249+{-# INLINE float64ArrayFrom #-}
250+
251+-- -----------------------------------------------------------------------------
252+
253+setIndexI :: Mutability m ~ IsMutable
254+ => Int -> Int -> SomeTypedArray e m -> JSM ()
255+setIndexI i x (SomeTypedArray a) = (a <## i) x
256+{-# INLINE setIndexI #-}
257+
258+unsafeSetIndexI :: Mutability m ~ IsMutable
259+ => Int -> Int -> SomeTypedArray e m -> JSM ()
260+unsafeSetIndexI i x (SomeTypedArray a) = (a <## i) x
261+{-# INLINE unsafeSetIndexI #-}
262+
263+setIndexW :: Mutability m ~ IsMutable
264+ => Int -> Word -> SomeTypedArray e m -> JSM ()
265+setIndexW i x (SomeTypedArray a) = (a <## i) x
266+{-# INLINE setIndexW #-}
267+
268+unsafeSetIndexW :: Mutability m ~ IsMutable
269+ => Int -> Word -> SomeTypedArray e m -> JSM ()
270+unsafeSetIndexW i x (SomeTypedArray a) = (a <## i) x
271+{-# INLINE unsafeSetIndexW #-}
272+
273+setIndexD :: Mutability m ~ IsMutable
274+ => Int -> Double -> SomeTypedArray e m -> JSM ()
275+setIndexD i x (SomeTypedArray a) = (a <## i) x
276+{-# INLINE setIndexD #-}
277+
278+unsafeSetIndexD :: Mutability m ~ IsMutable
279+ => Int -> Double -> SomeTypedArray e m -> JSM ()
280+unsafeSetIndexD i x (SomeTypedArray a) = (a <## i) x
281+{-# INLINE unsafeSetIndexD #-}
282+
283+indexOfI :: Mutability m ~ IsMutable
284+ => Int -> Int -> SomeTypedArray e m -> JSM Int
285+indexOfI s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
286+{-# INLINE indexOfI #-}
287+
288+indexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int
289+indexOfW s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
290+{-# INLINE indexOfW #-}
291+
292+indexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int
293+indexOfD s x (SomeTypedArray a) = a ^. js2 "indexOf" x s >>= fromJSValUnchecked
294+{-# INLINE indexOfD #-}
295+
296+lastIndexOfI :: Int -> Int -> SomeTypedArray e m -> JSM Int
297+lastIndexOfI s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
298+{-# INLINE lastIndexOfI #-}
299+
300+lastIndexOfW :: Int -> Word -> SomeTypedArray e m -> JSM Int
301+lastIndexOfW s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
302+{-# INLINE lastIndexOfW #-}
303+
304+lastIndexOfD :: Int -> Double -> SomeTypedArray e m -> JSM Int
305+lastIndexOfD s x (SomeTypedArray a) = a ^. js2 "lastIndexOf" x s >>= fromJSValUnchecked
306+{-# INLINE lastIndexOfD #-}
307+
308+-- -----------------------------------------------------------------------------
309+-- non-class operations usable for all typed array
310+{-| length of the typed array in elements -}
311+length :: SomeTypedArray e m -> GHCJSPure Int
312+length (SomeTypedArray a) = GHCJSPure $ a ^. js "length" >>= fromJSValUnchecked
313+{-# INLINE length #-}
314+
315+{-| length of the array in bytes -}
316+byteLength :: SomeTypedArray e m -> GHCJSPure Int
317+byteLength (SomeTypedArray a) = GHCJSPure $ a ^. js "byteLength" >>= fromJSValUnchecked
318+{-# INLINE byteLength #-}
319+
320+{-| offset of the array in the buffer -}
321+byteOffset :: SomeTypedArray e m -> GHCJSPure Int
322+byteOffset (SomeTypedArray a) = GHCJSPure $ a ^. js "byteOffset" >>= fromJSValUnchecked
323+{-# INLINE byteOffset #-}
324+
325+{-| the underlying buffer of the array -}
326+buffer :: SomeTypedArray e m -> GHCJSPure (SomeArrayBuffer m)
327+buffer (SomeTypedArray a) = GHCJSPure $ SomeArrayBuffer <$> a ^. js "buffer"
328+{-# INLINE buffer #-}
329+
330+{-| create a view of the existing array -}
331+subarray :: Int -> Int -> SomeTypedArray e m -> GHCJSPure (SomeTypedArray e m)
332+subarray begin end (SomeTypedArray a) = GHCJSPure$ SomeTypedArray <$> a ^. js2 "subarray" begin end
333+{-# INLINE subarray #-}
334+
335+-- fixme convert JSException to Haskell exception
336+{-| copy the elements of one typed array to another -}
337+set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure ()
338+set offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src
339+{-# INLINE set #-}
340+
341+unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> GHCJSPure ()
342+unsafeSet offset (SomeTypedArray src) (SomeTypedArray dest) = GHCJSPure $ void $ dest ^. js2 "set" offset src
343+{-# INLINE unsafeSet #-}
344+
jsaddle/src-ghc/JavaScript/TypedArray/Internal/Types.hsnew file+121
@@ -0,0 +1,121 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE PolyKinds #-}
5+
6+module JavaScript.TypedArray.Internal.Types where
7+
8+import GHCJS.Types
9+import GHCJS.Internal.Types
10+import Language.Javascript.JSaddle (IsJSVal)
11+
12+import Data.Int
13+import Data.Typeable
14+import Data.Word
15+
16+newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) =
17+ SomeTypedArray JSVal deriving Typeable
18+instance IsJSVal (SomeTypedArray e m)
19+
20+{-
21+newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal
22+ deriving (Typeable)
23+-}
24+
25+type SomeSTTypedArray s (e :: TypedArrayElem) = SomeTypedArray e (STMutable s)
26+
27+-- -----------------------------------------------------------------------------
28+
29+data TypedArrayElem = Int8Elem
30+ | Int16Elem
31+ | Int32Elem
32+ | Uint8Elem
33+ | Uint16Elem
34+ | Uint32Elem
35+ | Uint8ClampedElem
36+ | Float32Elem
37+ | Float64Elem
38+
39+-- -----------------------------------------------------------------------------
40+
41+type SomeInt8Array = SomeTypedArray Int8Elem
42+type SomeInt16Array = SomeTypedArray Int16Elem
43+type SomeInt32Array = SomeTypedArray Int32Elem
44+
45+type SomeUint8Array = SomeTypedArray Uint8Elem
46+type SomeUint16Array = SomeTypedArray Uint16Elem
47+type SomeUint32Array = SomeTypedArray Uint32Elem
48+
49+type SomeFloat32Array = SomeTypedArray Float32Elem
50+type SomeFloat64Array = SomeTypedArray Float64Elem
51+
52+type SomeUint8ClampedArray = SomeTypedArray Uint8ClampedElem
53+
54+-- -----------------------------------------------------------------------------
55+
56+type Int8Array = SomeInt8Array Immutable
57+type Int16Array = SomeInt16Array Immutable
58+type Int32Array = SomeInt32Array Immutable
59+
60+type Uint8Array = SomeUint8Array Immutable
61+type Uint16Array = SomeUint16Array Immutable
62+type Uint32Array = SomeUint32Array Immutable
63+
64+type Uint8ClampedArray = SomeUint8ClampedArray Immutable
65+
66+type Float32Array = SomeFloat32Array Immutable
67+type Float64Array = SomeFloat64Array Immutable
68+
69+-- -----------------------------------------------------------------------------
70+
71+type IOInt8Array = SomeInt8Array Mutable
72+type IOInt16Array = SomeInt16Array Mutable
73+type IOInt32Array = SomeInt32Array Mutable
74+
75+type IOUint8Array = SomeUint8Array Mutable
76+type IOUint16Array = SomeUint16Array Mutable
77+type IOUint32Array = SomeUint32Array Mutable
78+
79+type IOUint8ClampedArray = SomeUint8ClampedArray Mutable
80+
81+type IOFloat32Array = SomeFloat32Array Mutable
82+type IOFloat64Array = SomeFloat64Array Mutable
83+
84+-- -----------------------------------------------------------------------------
85+
86+type STInt8Array s = SomeSTTypedArray s Int8Elem
87+type STInt16Array s = SomeSTTypedArray s Int16Elem
88+type STInt32Array s = SomeSTTypedArray s Int32Elem
89+
90+type STUint8Array s = SomeSTTypedArray s Uint8Elem
91+type STUint16Array s = SomeSTTypedArray s Uint16Elem
92+type STUint32Array s = SomeSTTypedArray s Uint32Elem
93+
94+type STFloat32Array s = SomeSTTypedArray s Float32Elem
95+type STFloat64Array s = SomeSTTypedArray s Float64Elem
96+
97+type STUint8ClampedArray s = SomeSTTypedArray s Uint8ClampedElem
98+
99+-- -----------------------------------------------------------------------------
100+
101+type family Elem x where
102+ Elem (SomeUint8Array m) = Word8
103+ Elem (SomeUint8ClampedArray m) = Word8
104+ Elem (SomeUint16Array m) = Word16
105+ Elem (SomeUint32Array m) = Word
106+ Elem (SomeInt8Array m) = Int8
107+ Elem (SomeInt16Array m) = Int16
108+ Elem (SomeInt32Array m) = Int
109+ Elem (SomeFloat32Array m) = Double
110+ Elem (SomeFloat64Array m) = Double
111+
112+ Elem (STUint8Array s) = Word8
113+ Elem (STUint8ClampedArray s) = Word8
114+ Elem (STUint16Array s) = Word16
115+ Elem (STUint32Array s) = Word
116+ Elem (STInt8Array s) = Int8
117+ Elem (STInt16Array s) = Int16
118+ Elem (STInt32Array s) = Int
119+ Elem (STFloat32Array s) = Double
120+ Elem (STFloat64Array s) = Double
121+
jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs+2−6
@@ -27,9 +27,7 @@ import Control.Monad.IO.Class (MonadIO(..))
27import Language.Javascript.JSaddle.Types (JSString)
27import Language.Javascript.JSaddle.Types (JSString)
28#else
28#else
29import Language.Javascript.JSaddle.Native.Internal
29import Language.Javascript.JSaddle.Native.Internal
30− (withJSString)
30+ (evaluateScript)
31−import Language.Javascript.JSaddle.Run
32− (AsyncCommand(..), sendLazyCommand)
33#endif
31#endif
34import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))
32import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))
35import Language.Javascript.JSaddle.Monad (JSM)
33import Language.Javascript.JSaddle.Monad (JSM)
@@ -55,7 +53,5 @@ eval script = liftIO $ js_eval (toJSString script)
55foreign import javascript unsafe "$r = eval($1);"
53foreign import javascript unsafe "$r = eval($1);"
56 js_eval :: JSString -> IO JSVal
54 js_eval :: JSString -> IO JSVal
57#else
55#else
58−eval script = do
56+eval = evaluateScript . toJSString
59− let rscript = toJSString script
60− withJSString rscript $ sendLazyCommand . EvaluateScript
61#endif
57#endif
jsaddle/src/Language/Javascript/JSaddle/Exception.hs+6−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2-----------------------------------------------------------------------------
3-----------------------------------------------------------------------------
3--
4--
@@ -17,7 +18,11 @@ module Language.Javascript.JSaddle.Exception (
17) where
18) where
18
19
19import qualified Control.Exception as E (Exception)
20import qualified Control.Exception as E (Exception)
20−import Language.Javascript.JSaddle.Types (JSVal)
21+#ifdef ghcjs_HOST_OS
22+import GHCJS.Prim (JSVal)
23+#else
24+import GHCJS.Prim.Internal (JSVal)
25+#endif
21import Data.Typeable (Typeable)
26import Data.Typeable (Typeable)
22
27
23newtype JSException = JSException JSVal deriving (Typeable)
28newtype JSException = JSException JSVal deriving (Typeable)
jsaddle/src/Language/Javascript/JSaddle/Foreign.hsdeleted−99
@@ -1,99 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-----------------------------------------------------------------------------
3−--
4−-- Module : Language.Javascript.JSaddle.Value
5−-- Copyright : (c) Hamish Mackenzie
6−-- License : MIT
7−--
8−-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
9−--
10−-- | This module is like `GHCJS.Foreign` but some functions are in
11−--
12−-----------------------------------------------------------------------------
13−module Language.Javascript.JSaddle.Foreign (
14− jsTrue
15− , jsFalse
16− , jsNull
17− , toJSBool
18−-- , fromJSBoolIO
19− , jsUndefined
20− , isTruthyIO
21− , isNullIO
22− , isUndefinedIO
23−-- , isObjectIO
24−-- , isFunctionIO
25−-- , isStringIO
26−-- , isBooleanIO
27−-- , isSymbolIO
28−-- , isNumberIO
29−) where
30−
31−#ifdef ghcjs_HOST_OS
32−import Language.Javascript.JSaddle.Types (JSM, JSVal)
33−import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined, jsTrue, jsFalse, isNull, isUndefined)
34−#else
35−import Language.Javascript.JSaddle.Types (JSM, JSVal(..))
36−import Language.Javascript.JSaddle.Native.Internal
37− (withJSVal)
38−import Language.Javascript.JSaddle.Run
39− (Command(..), Result(..), sendCommand)
40−#endif
41−
42−#ifndef ghcjs_HOST_OS
43−jsTrue :: JSVal
44−jsTrue = JSVal 3
45−{-# INLINE jsTrue #-}
46−
47−jsFalse :: JSVal
48−jsFalse = JSVal 2
49−{-# INLINE jsFalse #-}
50−
51−jsNull :: JSVal
52−jsNull = JSVal 0
53−{-# INLINE jsNull #-}
54−
55−toJSBool :: Bool -> JSVal
56−toJSBool b = JSVal $ if b then 3 else 2
57−{-# INLINE toJSBool #-}
58−
59−jsUndefined :: JSVal
60−jsUndefined = JSVal 1
61−{-# INLINE jsUndefined #-}
62−#endif
63−
64−isTruthyIO :: JSVal -> JSM Bool
65−#ifdef ghcjs_HOST_OS
66−isTruthyIO = return . isTruthy
67−#else
68−isTruthyIO (JSVal 0) = return False -- null
69−isTruthyIO (JSVal 1) = return False -- undefined
70−isTruthyIO (JSVal 2) = return False -- false
71−isTruthyIO (JSVal 3) = return True -- true
72−isTruthyIO v = withJSVal v $ \rval -> do
73− ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)
74− return result
75−#endif
76−{-# INLINE isTruthyIO #-}
77−
78−isNullIO :: JSVal -> JSM Bool
79−#ifdef ghcjs_HOST_OS
80−isNullIO = return . isNull
81−#else
82−isNullIO (JSVal 0) = return True
83−isNullIO v = withJSVal v $ \rval -> do
84− ~(IsNullResult result) <- sendCommand $ IsNull rval
85− return result
86−#endif
87−{-# INLINE isNullIO #-}
88−
89−isUndefinedIO :: JSVal -> JSM Bool
90−#ifdef ghcjs_HOST_OS
91−isUndefinedIO = return . isUndefined
92−#else
93−isUndefinedIO (JSVal 1) = return True
94−isUndefinedIO v = withJSVal v $ \rval -> do
95− ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval
96− return result
97−#endif
98−{-# INLINE isUndefinedIO #-}
99−
jsaddle/src/Language/Javascript/JSaddle/Native.hs+1−6
@@ -11,12 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12
12
13module Language.Javascript.JSaddle.Native (
13module Language.Javascript.JSaddle.Native (
14− wrapJSVal
14+ module Language.Javascript.JSaddle.Native.Internal
15− , wrapJSString
16− , withJSVal
17− , withJSVals
18− , withObject
19− , withJSString
20 , withToJSVal
15 , withToJSVal
21) where
16) where
22
17
jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+180−15
@@ -17,26 +17,45 @@ module Language.Javascript.JSaddle.Native.Internal (
17 , withJSVals
17 , withJSVals
18 , withObject
18 , withObject
19 , withJSString
19 , withJSString
20+ , setPropertyByName
21+ , setPropertyAtIndex
22+ , stringToValue
23+ , numberToValue
24+ , jsonValueToValue
25+ , getPropertyByName
26+ , getPropertyAtIndex
27+ , callAsFunction
28+ , callAsConstructor
29+ , newEmptyObject
30+ , newCallback
31+ , newArray
32+ , evaluateScript
33+ , deRefVal
34+ , valueToBool
35+ , valueToNumber
36+ , valueToString
37+ , valueToJSON
38+ , valueToJSONValue
39+ , isNull
40+ , isUndefined
41+ , strictEqual
42+ , instanceOf
43+ , propertyNames
20) where
44) where
21
45
22−import Control.Monad.Trans.Reader (ask)
23import Control.Monad.IO.Class (MonadIO(..))
46import Control.Monad.IO.Class (MonadIO(..))
47+import Control.Monad.Primitive (touch)
48+
49+import Data.Aeson (Value)
50+
24import Language.Javascript.JSaddle.Types
51import Language.Javascript.JSaddle.Types
25− (JSContextRef(..), AsyncCommand(..), JSM(..), JSString(..),
52+ (AsyncCommand(..), JSM(..), JSString(..), addCallback,
26− Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..),
53+ Object(..), JSVal(..), JSValueForSend(..), JSCallAsFunction,
27 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))
54 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))
28−import System.Mem.Weak (addFinalizer)
55+import Language.Javascript.JSaddle.Monad (askJSM)
29−import Control.Monad.Primitive (touch)
56+import Language.Javascript.JSaddle.Run
30−import Control.Monad (when)
57+ (Command(..), AsyncCommand(..), Result(..), sendCommand,
31−
58+ sendAsyncCommand, sendLazyCommand, wrapJSVal)
32−wrapJSVal :: JSValueReceived -> JSM JSVal
33−wrapJSVal (JSValueReceived ref) = do
34− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
35− let result = JSVal ref
36− when (ref >= 5) $ do
37− ctx <- JSM ask
38− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
39− return result
40
59
41wrapJSString :: MonadIO m => JSStringReceived -> m JSString
60wrapJSString :: MonadIO m => JSStringReceived -> m JSString
42wrapJSString (JSStringReceived ref) = return $ JSString ref
61wrapJSString (JSStringReceived ref) = return $ JSString ref
@@ -62,3 +81,149 @@ withJSString v@(JSString ref) f =
62 liftIO $ touch v
81 liftIO $ touch v
63 return result
82 return result
64
83
84+setPropertyByName :: JSString -> JSVal -> Object -> JSM ()
85+setPropertyByName name val this =
86+ withObject this $ \rthis ->
87+ withJSString name $ \rname ->
88+ withJSVal val $ \rval ->
89+ sendAsyncCommand $ SetPropertyByName rthis rname rval
90+{-# INLINE setPropertyByName #-}
91+
92+setPropertyAtIndex :: Int -> JSVal -> Object -> JSM ()
93+setPropertyAtIndex index val this =
94+ withObject this $ \rthis ->
95+ withJSVal val $ \rval ->
96+ sendAsyncCommand $ SetPropertyAtIndex rthis index rval
97+{-# INLINE setPropertyAtIndex #-}
98+
99+stringToValue :: JSString -> JSM JSVal
100+stringToValue s = withJSString s $ sendLazyCommand . StringToValue
101+{-# INLINE stringToValue #-}
102+
103+numberToValue :: Double -> JSM JSVal
104+numberToValue = sendLazyCommand . NumberToValue
105+{-# INLINE numberToValue #-}
106+
107+jsonValueToValue :: Value -> JSM JSVal
108+jsonValueToValue = sendLazyCommand . JSONValueToValue
109+{-# INLINE jsonValueToValue #-}
110+
111+getPropertyByName :: JSString -> Object -> JSM JSVal
112+getPropertyByName name this =
113+ withObject this $ \rthis ->
114+ withJSString name $ sendLazyCommand . GetPropertyByName rthis
115+{-# INLINE getPropertyByName #-}
116+
117+getPropertyAtIndex :: Int -> Object -> JSM JSVal
118+getPropertyAtIndex index this =
119+ withObject this $ \rthis -> sendLazyCommand $ GetPropertyAtIndex rthis index
120+{-# INLINE getPropertyAtIndex #-}
121+
122+callAsFunction :: Object -> Object -> [JSVal] -> JSM JSVal
123+callAsFunction f this args =
124+ withObject f $ \rfunction ->
125+ withObject this $ \rthis ->
126+ withJSVals args $ sendLazyCommand . CallAsFunction rfunction rthis
127+{-# INLINE callAsFunction #-}
128+
129+callAsConstructor :: Object -> [JSVal] -> JSM JSVal
130+callAsConstructor f args =
131+ withObject f $ \rfunction ->
132+ withJSVals args $ sendLazyCommand . CallAsConstructor rfunction
133+{-# INLINE callAsConstructor #-}
134+
135+newEmptyObject :: JSM Object
136+newEmptyObject = Object <$> sendLazyCommand NewEmptyObject
137+{-# INLINE newEmptyObject #-}
138+
139+newCallback :: JSCallAsFunction -> JSM Object
140+newCallback f = do
141+ object <- Object <$> sendLazyCommand NewCallback
142+ add <- addCallback <$> askJSM
143+ liftIO $ add object f
144+ return object
145+{-# INLINE newCallback #-}
146+
147+newArray :: [JSVal] -> JSM JSVal
148+newArray xs = withJSVals xs $ \xs' -> sendLazyCommand (NewArray xs')
149+{-# INLINE newArray #-}
150+
151+evaluateScript :: JSString -> JSM JSVal
152+evaluateScript script = withJSString script $ sendLazyCommand . EvaluateScript
153+{-# INLINE evaluateScript #-}
154+
155+deRefVal :: JSVal -> JSM Result
156+deRefVal value = withJSVal value $ sendCommand . DeRefVal
157+{-# INLINE deRefVal #-}
158+
159+valueToBool :: JSVal -> JSM Bool
160+valueToBool (JSVal 0) = return False -- null
161+valueToBool (JSVal 1) = return False -- undefined
162+valueToBool (JSVal 2) = return False -- false
163+valueToBool (JSVal 3) = return True -- true
164+valueToBool v = withJSVal v $ \rval -> do
165+ ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)
166+ return result
167+{-# INLINE valueToBool #-}
168+
169+valueToNumber :: JSVal -> JSM Double
170+valueToNumber value =
171+ withJSVal value $ \rval -> do
172+ ~(ValueToNumberResult result) <- sendCommand (ValueToNumber rval)
173+ return result
174+{-# INLINE valueToNumber #-}
175+
176+valueToString :: JSVal -> JSM JSString
177+valueToString value = withJSVal value $ \rval -> do
178+ ~(ValueToStringResult result) <- sendCommand (ValueToString rval)
179+ wrapJSString result
180+{-# INLINE valueToString #-}
181+
182+valueToJSON :: JSVal -> JSM JSString
183+valueToJSON value = withJSVal value $ \rval -> do
184+ ~(ValueToJSONResult result) <- sendCommand (ValueToJSON rval)
185+ wrapJSString result
186+{-# INLINE valueToJSON #-}
187+
188+valueToJSONValue :: JSVal -> JSM Value
189+valueToJSONValue value = withJSVal value $ \rval -> do
190+ ~(ValueToJSONValueResult result) <- sendCommand (ValueToJSONValue rval)
191+ return result
192+{-# INLINE valueToJSONValue #-}
193+
194+isNull :: JSVal -> JSM Bool
195+isNull (JSVal 0) = return True
196+isNull v = withJSVal v $ \rval -> do
197+ ~(IsNullResult result) <- sendCommand $ IsNull rval
198+ return result
199+{-# INLINE isNull #-}
200+
201+isUndefined :: JSVal -> JSM Bool
202+isUndefined (JSVal 1) = return True
203+isUndefined v = withJSVal v $ \rval -> do
204+ ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval
205+ return result
206+{-# INLINE isUndefined #-}
207+
208+strictEqual :: JSVal -> JSVal -> JSM Bool
209+strictEqual a b =
210+ withJSVal a $ \aref ->
211+ withJSVal b $ \bref -> do
212+ ~(StrictEqualResult result) <- sendCommand $ StrictEqual aref bref
213+ return result
214+{-# INLINE strictEqual #-}
215+
216+instanceOf :: JSVal -> Object -> JSM Bool
217+instanceOf value constructor =
218+ withJSVal value $ \rval ->
219+ withObject constructor $ \c' -> do
220+ ~(InstanceOfResult result) <- sendCommand $ InstanceOf rval c'
221+ return result
222+{-# INLINE instanceOf #-}
223+
224+propertyNames :: Object -> JSM [JSString]
225+propertyNames this =
226+ withObject this $ \rthis -> do
227+ ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis
228+ mapM wrapJSString result
229+{-# INLINE propertyNames #-}
jsaddle/src/Language/Javascript/JSaddle/Object.hs+4−11
@@ -115,9 +115,7 @@ import Language.Javascript.JSaddle.Types
115#else
115#else
116import GHCJS.Marshal.Internal (ToJSVal(..))
116import GHCJS.Marshal.Internal (ToJSVal(..))
117import Language.Javascript.JSaddle.Native
117import Language.Javascript.JSaddle.Native
118− (withJSVals, withObject)
118+ (newCallback, callAsFunction, callAsConstructor)
119−import Language.Javascript.JSaddle.Run
120− (AsyncCommand(..), sendLazyCommand)
121import Language.Javascript.JSaddle.Monad (askJSM, JSM)
119import Language.Javascript.JSaddle.Monad (askJSM, JSM)
122import Language.Javascript.JSaddle.Types
120import Language.Javascript.JSaddle.Types
123 (JSString, Object(..), SomeJSArray(..),
121 (JSString, Object(..), SomeJSArray(..),
@@ -450,9 +448,7 @@ foreign import javascript unsafe "$r = function () { $1(this, arguments); }"
450 makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
448 makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object
451#else
449#else
452function f = do
450function f = do
453− object <- Object <$> sendLazyCommand NewCallback
451+ object <- newCallback f
454− add <- addCallback <$> askJSM
455− liftIO $ add object f
456 return $ Function object
452 return $ Function object
457#endif
453#endif
458
454
@@ -532,9 +528,7 @@ foreign import javascript unsafe "$r = $1.apply($2, $3)"
532#else
528#else
533objCallAsFunction f this args = do
529objCallAsFunction f this args = do
534 rargs <- makeArgs args
530 rargs <- makeArgs args
535− withObject f $ \rfunction ->
531+ callAsFunction f this rargs
536− withObject this $ \rthis ->
537− withJSVals rargs $ sendLazyCommand . CallAsFunction rfunction rthis
538#endif
532#endif
539
533
540-- | Call a JavaScript object as a constructor. Consider using 'new'.
534-- | Call a JavaScript object as a constructor. Consider using 'new'.
@@ -576,8 +570,7 @@ foreign import javascript unsafe "\
576#else
570#else
577objCallAsConstructor f args = do
571objCallAsConstructor f args = do
578 rargs <- makeArgs args
572 rargs <- makeArgs args
579− withObject f $ \rfunction ->
573+ callAsConstructor f rargs
580− withJSVals rargs $ sendLazyCommand . CallAsConstructor rfunction
581#endif
574#endif
582
575
583-- >>> testJSaddle $ strictEqual nullObject (eval "null")
576-- >>> testJSaddle $ strictEqual nullObject (eval "null")
jsaddle/src/Language/Javascript/JSaddle/Run.hs+13−2
@@ -28,6 +28,7 @@ module Language.Javascript.JSaddle.Run (
28 , sendCommand
28 , sendCommand
29 , sendLazyCommand
29 , sendLazyCommand
30 , sendAsyncCommand
30 , sendAsyncCommand
31+ , wrapJSVal
31#endif
32#endif
32) where
33) where
33
34
@@ -37,7 +38,7 @@ import qualified JavaScript.Web.AnimationFrame as GHCJS
37 (waitForAnimationFrame)
38 (waitForAnimationFrame)
38#else
39#else
39import Control.Exception (throwIO)
40import Control.Exception (throwIO)
40−import Control.Monad (void, forever, zipWithM_)
41+import Control.Monad (void, when, forever, zipWithM_)
41import Control.Monad.IO.Class (MonadIO(..))
42import Control.Monad.IO.Class (MonadIO(..))
42import Control.Monad.Trans.Reader (ask, runReaderT)
43import Control.Monad.Trans.Reader (ask, runReaderT)
43import Control.Monad.STM (atomically)
44import Control.Monad.STM (atomically)
@@ -50,6 +51,7 @@ import Control.Concurrent.MVar
50 (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
51 (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
51
52
52import System.IO.Unsafe (unsafeInterleaveIO)
53import System.IO.Unsafe (unsafeInterleaveIO)
54+import System.Mem.Weak (addFinalizer)
53
55
54import Data.Monoid ((<>))
56import Data.Monoid ((<>))
55import qualified Data.Text as T (unpack)
57import qualified Data.Text as T (unpack)
@@ -60,7 +62,7 @@ import Language.Javascript.JSaddle.Types
60 (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
62 (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
61 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
63 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
62import Language.Javascript.JSaddle.Exception (JSException(..))
64import Language.Javascript.JSaddle.Exception (JSException(..))
63−import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
65+-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
64import Control.DeepSeq (deepseq)
66import Control.DeepSeq (deepseq)
65#endif
67#endif
66
68
@@ -202,4 +204,13 @@ runJavaScript sendBatch entryPoint = do
202 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
204 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
203 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
205 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
204 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
206 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
207+
208+wrapJSVal :: JSValueReceived -> JSM JSVal
209+wrapJSVal (JSValueReceived ref) = do
210+ -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
211+ let result = JSVal ref
212+ when (ref >= 5) $ do
213+ ctx <- JSM ask
214+ liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
215+ return result
205#endif
216#endif
jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+54
@@ -329,4 +329,58 @@ ghcjsHelpers = "\
329 \ }\n\
329 \ }\n\
330 \\n\
330 \\n\
331 \}\n\
331 \}\n\
332+ \function h$roundUpToMultipleOf(n,m) {\n\
333+ \ var rem = n % m;\n\
334+ \ return rem === 0 ? n : n - rem + m;\n\
335+ \}\n\
336+ \\n\
337+ \function h$newByteArray(len) {\n\
338+ \ var len0 = Math.max(h$roundUpToMultipleOf(len, 8), 8);\n\
339+ \ var buf = new ArrayBuffer(len0);\n\
340+ \ return { buf: buf\n\
341+ \ , len: len\n\
342+ \ , i3: new Int32Array(buf)\n\
343+ \ , u8: new Uint8Array(buf)\n\
344+ \ , u1: new Uint16Array(buf)\n\
345+ \ , f3: new Float32Array(buf)\n\
346+ \ , f6: new Float64Array(buf)\n\
347+ \ , dv: new DataView(buf)\n\
348+ \ }\n\
349+ \}\n\
350+ \function h$wrapBuffer(buf, unalignedOk, offset, length) {\n\
351+ \ if(!unalignedOk && offset && offset % 8 !== 0) {\n\
352+ \ throw (\"h$wrapBuffer: offset not aligned:\" + offset);\n\
353+ \ }\n\
354+ \ if(!buf || !(buf instanceof ArrayBuffer))\n\
355+ \ throw \"h$wrapBuffer: not an ArrayBuffer\"\n\
356+ \ if(!offset) { offset = 0; }\n\
357+ \ if(!length || length < 0) { length = buf.byteLength - offset; }\n\
358+ \ return { buf: buf\n\
359+ \ , len: length\n\
360+ \ , i3: (offset%4) ? null : new Int32Array(buf, offset, length >> 2)\n\
361+ \ , u8: new Uint8Array(buf, offset, length)\n\
362+ \ , u1: (offset%2) ? null : new Uint16Array(buf, offset, length >> 1)\n\
363+ \ , f3: (offset%4) ? null : new Float32Array(buf, offset, length >> 2)\n\
364+ \ , f6: (offset%8) ? null : new Float64Array(buf, offset, length >> 3)\n\
365+ \ , dv: new DataView(buf, offset, length)\n\
366+ \ };\n\
367+ \}\n\
368+ \function h$newByteArrayFromBase64String(base64) {\n\
369+ \ var bin = window.atob(base64);\n\
370+ \ var ba = h$newByteArray(bin.length);\n\
371+ \ var u8 = ba.u8;\n\
372+ \ for (var i = 0; i < bin.length; i++) {\n\
373+ \ u8[i] = bin.charCodeAt(i);\n\
374+ \ }\n\
375+ \ return ba;\n\
376+ \}\n\
377+ \function h$byteArrayToBase64String(off, len, ba) {\n\
378+ \ var bin = '';\n\
379+ \ var u8 = ba.u8;\n\
380+ \ var end = off + len;\n\
381+ \ for (var i = off; i < end; i++) {\n\
382+ \ bin += String.fromCharCode(u8[i]);\n\
383+ \ }\n\
384+ \ return window.btoa(bin);\n\
385+ \}\n\
332 \"
386 \"
jsaddle/src/Language/Javascript/JSaddle/Types.hs+67−17
@@ -7,11 +7,11 @@
7{-# LANGUAGE UndecidableInstances #-}
7{-# LANGUAGE UndecidableInstances #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE DeriveGeneric #-}
9{-# LANGUAGE DeriveGeneric #-}
10−{-# LANGUAGE DefaultSignatures #-}
11{-# LANGUAGE DataKinds #-}
10{-# LANGUAGE DataKinds #-}
12{-# LANGUAGE KindSignatures #-}
11{-# LANGUAGE KindSignatures #-}
13{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE PolyKinds #-}
14{-# LANGUAGE FlexibleContexts #-}
13{-# LANGUAGE FlexibleContexts #-}
14+{-# LANGUAGE DefaultSignatures #-}
15#endif
15#endif
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17--
17--
@@ -34,13 +34,20 @@ module Language.Javascript.JSaddle.Types (
34 , MonadJSM(..)
34 , MonadJSM(..)
35 , liftJSM
35 , liftJSM
36
36
37+ -- * Pure GHCJS functions
38+ , GHCJSPure(..)
39+ , ghcjsPure
40+ , ghcjsPureMap
41+ , ghcjsPureId
42+
37 -- * JavaScript Value Types
43 -- * JavaScript Value Types
38 , JSVal(..)
44 , JSVal(..)
39− , IsJSVal
45+ , IsJSVal(..)
40 , jsval
46 , jsval
41 , SomeJSArray(..)
47 , SomeJSArray(..)
42 , JSArray
48 , JSArray
43 , MutableJSArray
49 , MutableJSArray
50+ , STJSArray
44 , Object(..)
51 , Object(..)
45 , JSString(..)
52 , JSString(..)
46 , Nullable(..)
53 , Nullable(..)
@@ -48,6 +55,11 @@ module Language.Javascript.JSaddle.Types (
48
55
49 -- * JavaScript Context Commands
56 -- * JavaScript Context Commands
50#ifndef ghcjs_HOST_OS
57#ifndef ghcjs_HOST_OS
58+ , MutabilityType(..)
59+ , Mutable
60+ , Immutable
61+ , IsItMutable(..)
62+ , Mutability
51 , JSValueReceived(..)
63 , JSValueReceived(..)
52 , JSValueForSend(..)
64 , JSValueForSend(..)
53 , JSStringReceived(..)
65 , JSStringReceived(..)
@@ -65,9 +77,11 @@ import Control.Monad.IO.Class (MonadIO(..))
65#ifdef ghcjs_HOST_OS
77#ifdef ghcjs_HOST_OS
66import GHCJS.Types
78import GHCJS.Types
67import JavaScript.Object.Internal (Object(..))
79import JavaScript.Object.Internal (Object(..))
68−import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray)
80+import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray, STJSArray)
69import GHCJS.Nullable (Nullable(..))
81import GHCJS.Nullable (Nullable(..))
70#else
82#else
83+import GHCJS.Prim.Internal (JSVal(..), JSValueRef)
84+import Data.JSString.Internal.Type (JSString(..))
71import Control.DeepSeq (NFData(..))
85import Control.DeepSeq (NFData(..))
72import Control.Monad.Trans.Reader (ReaderT(..))
86import Control.Monad.Trans.Reader (ReaderT(..))
73import Control.Monad.Trans.State.Lazy (StateT(..))
87import Control.Monad.Trans.State.Lazy (StateT(..))
@@ -77,11 +91,10 @@ import Control.Monad.Trans.Class (MonadTrans(..))
77import Control.Monad.Fix (MonadFix)
91import Control.Monad.Fix (MonadFix)
78import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
92import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))
79import Control.Concurrent.STM.TVar (TVar)
93import Control.Concurrent.STM.TVar (TVar)
80−import Data.Coerce (Coercible, coerce)
81−import Data.Int (Int64)
82import Data.Text (Text)
94import Data.Text (Text)
83import Data.Time.Clock (UTCTime(..))
95import Data.Time.Clock (UTCTime(..))
84import Data.Typeable (Typeable)
96import Data.Typeable (Typeable)
97+import Data.Coerce (coerce, Coercible)
85import Data.Aeson
98import Data.Aeson
86 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
99 (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)
87import GHC.Generics (Generic)
100import GHC.Generics (Generic)
@@ -119,6 +132,47 @@ newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }
119 deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
132 deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
120#endif
133#endif
121
134
135+
136+-- | Type we can give to functions that are pure when using ghcjs, but
137+-- live in JSM when using jsaddle.
138+--
139+-- Some functions that can be pure in GHCJS cannot be implemented in
140+-- a pure way in JSaddle (because we need to know the JSContextRef).
141+-- Instead we implement versions of these functions in that return
142+-- `GHCJSPure a` instead of `a`. To call them in a way that will
143+-- work when compiling with GHCJS use `ghcjsPure`.
144+#ifdef ghcjs_HOST_OS
145+type GHCJSPure a = a
146+#else
147+newtype GHCJSPure a = GHCJSPure (JSM a)
148+#endif
149+
150+-- | Used when you want to call a functions that is pure in GHCJS, but
151+-- lives in the JSM in jsaddle.
152+ghcjsPure :: GHCJSPure a -> JSM a
153+#ifdef ghcjs_HOST_OS
154+ghcjsPure = pure
155+#else
156+ghcjsPure (GHCJSPure x) = x
157+#endif
158+{-# INLINE ghcjsPure #-}
159+
160+ghcjsPureMap :: (a -> b) -> GHCJSPure a -> GHCJSPure b
161+#ifdef ghcjs_HOST_OS
162+ghcjsPureMap = id
163+#else
164+ghcjsPureMap f (GHCJSPure x) = GHCJSPure (f <$> x)
165+#endif
166+{-# INLINE ghcjsPureMap #-}
167+
168+ghcjsPureId :: a -> GHCJSPure a
169+#ifdef ghcjs_HOST_OS
170+ghcjsPureId = id
171+#else
172+ghcjsPureId = GHCJSPure . return
173+#endif
174+{-# INLINE ghcjsPureId #-}
175+
122-- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'.
176-- | The 'MonadJSM' is to 'JSM' what 'MonadIO' is to 'IO'.
123-- When using GHCJS it is 'MonadIO'.
177-- When using GHCJS it is 'MonadIO'.
124#ifdef ghcjs_HOST_OS
178#ifdef ghcjs_HOST_OS
@@ -175,23 +229,18 @@ type JSCallAsFunction = JSVal -- ^ Function object
175 -- as an argument and invoke it from haskell.
229 -- as an argument and invoke it from haskell.
176
230
177#ifndef ghcjs_HOST_OS
231#ifndef ghcjs_HOST_OS
178−-- A reference to a particular JavaScript value inside the JavaScript context
179−type JSValueRef = Int64
180−
181−-- | See 'GHCJS.Prim.JSVal'
182−newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)
183
232
184instance NFData JSVal where
233instance NFData JSVal where
185 rnf x = x `seq` ()
234 rnf x = x `seq` ()
186
235
187class IsJSVal a where
236class IsJSVal a where
188− jsval_ :: a -> JSVal
237+ jsval_ :: a -> GHCJSPure JSVal
189
238
190− default jsval_ :: Coercible a JSVal => a -> JSVal
239+ default jsval_ :: Coercible a JSVal => a -> GHCJSPure JSVal
191− jsval_ = coerce
240+ jsval_ = GHCJSPure . return . coerce
192 {-# INLINE jsval_ #-}
241 {-# INLINE jsval_ #-}
193
242
194−jsval :: IsJSVal a => a -> JSVal
243+jsval :: IsJSVal a => a -> GHCJSPure JSVal
195jsval = jsval_
244jsval = jsval_
196{-# INLINE jsval #-}
245{-# INLINE jsval #-}
197
246
@@ -212,21 +261,22 @@ type family Mutability (a :: MutabilityType s) :: IsItMutable where
212
261
213newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
262newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal
214 deriving (Typeable)
263 deriving (Typeable)
264+instance IsJSVal (SomeJSArray m)
215
265
216-- | See 'JavaScript.Array.Internal.JSArray'
266-- | See 'JavaScript.Array.Internal.JSArray'
217type JSArray = SomeJSArray Immutable
267type JSArray = SomeJSArray Immutable
218-- | See 'JavaScript.Array.Internal.MutableJSArray'
268-- | See 'JavaScript.Array.Internal.MutableJSArray'
219type MutableJSArray = SomeJSArray Mutable
269type MutableJSArray = SomeJSArray Mutable
220
270
271+-- | See 'JavaScript.Array.Internal.STJSArray'
272+type STJSArray s = SomeJSArray (STMutable s)
273+
221-- | See 'JavaScript.Object.Internal.Object'
274-- | See 'JavaScript.Object.Internal.Object'
222newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)
275newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)
223
276
224-- | See 'GHCJS.Nullable.Nullable'
277-- | See 'GHCJS.Nullable.Nullable'
225newtype Nullable a = Nullable a
278newtype Nullable a = Nullable a
226
279
227−-- | See 'Data.JSString.Internal.Type'
228−newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON)
229−
230-- | Wrapper used when receiving a 'JSVal' from the JavaScript context
280-- | Wrapper used when receiving a 'JSVal' from the JavaScript context
231newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
281newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
232
282
jsaddle/src/Language/Javascript/JSaddle/Value.hs+57−89
@@ -45,7 +45,7 @@ module Language.Javascript.JSaddle.Value (
45 , showJSValue
45 , showJSValue
46
46
47 -- * Converting JavaScript values
47 -- * Converting JavaScript values
48− , isTruthyIO
48+ , isTruthy
49 , valToBool
49 , valToBool
50 , valToNumber
50 , valToNumber
51 , valToStr
51 , valToStr
@@ -57,11 +57,11 @@ module Language.Javascript.JSaddle.Value (
57 , val
57 , val
58 , jsNull
58 , jsNull
59 , valNull
59 , valNull
60− , isNullIO
60+ , isNull
61 , valIsNull
61 , valIsNull
62 , jsUndefined
62 , jsUndefined
63 , valUndefined
63 , valUndefined
64− , isUndefinedIO
64+ , isUndefined
65 , valIsUndefined
65 , valIsUndefined
66 , maybeNullOrUndefined
66 , maybeNullOrUndefined
67 , maybeNullOrUndefined'
67 , maybeNullOrUndefined'
@@ -84,32 +84,32 @@ module Language.Javascript.JSaddle.Value (
84import Data.Text (Text)
84import Data.Text (Text)
85import qualified Data.Text as T (pack, unpack)
85import qualified Data.Text as T (pack, unpack)
86import Data.Aeson (Value)
86import Data.Aeson (Value)
87+import Data.JSString.Text (textToJSString)
87
88
88#ifdef ghcjs_HOST_OS
89#ifdef ghcjs_HOST_OS
89import Language.Javascript.JSaddle.Types
90import Language.Javascript.JSaddle.Types
90− (Object(..), JSString(..), JSVal(..))
91+ (Object(..), JSString(..), JSVal(..), ghcjsPure)
91import GHCJS.Marshal (ToJSVal(..))
92import GHCJS.Marshal (ToJSVal(..))
92import GHCJS.Marshal.Pure (pToJSVal)
93import GHCJS.Marshal.Pure (pToJSVal)
93−import Data.JSString.Text (textToJSString)
94#else
94#else
95import Data.Char (chr, ord)
95import Data.Char (chr, ord)
96import Data.Word (Word, Word8, Word16, Word32)
96import Data.Word (Word, Word8, Word16, Word32)
97import Data.Int (Int8, Int16, Int32)
97import Data.Int (Int8, Int16, Int32)
98import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
98import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
99import Language.Javascript.JSaddle.Types
99import Language.Javascript.JSaddle.Types
100− (Object(..), JSString(..), JSVal(..))
100+ (Object(..), JSString(..), JSVal(..), ghcjsPure)
101import Language.Javascript.JSaddle.Native
101import Language.Javascript.JSaddle.Native
102− (wrapJSString, withJSVal, withObject, withJSString, withToJSVal)
102+ (valueToNumber, valueToString, valueToJSON, numberToValue, stringToValue, jsonValueToValue)
103+import qualified Language.Javascript.JSaddle.Native as N
104+ (deRefVal, strictEqual, instanceOf)
103−import Language.Javascript.JSaddle.Run
105+import Language.Javascript.JSaddle.Run (Result(..))
104− (Command(..), AsyncCommand(..), Result(..), sendCommand,
105− sendLazyCommand)
106#endif
106#endif
107import Language.Javascript.JSaddle.Monad (JSM)
107import Language.Javascript.JSaddle.Monad (JSM)
108import Language.Javascript.JSaddle.Classes
108import Language.Javascript.JSaddle.Classes
109 (MakeObject(..), MakeArgs(..))
109 (MakeObject(..), MakeArgs(..))
110import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
110import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))
111import Language.Javascript.JSaddle.String (strToText, textToStr)
111import Language.Javascript.JSaddle.String (strToText, textToStr)
112−import Language.Javascript.JSaddle.Foreign (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthyIO, isNullIO, isUndefinedIO)
112+import GHCJS.Foreign.Internal (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthy, isNull, isUndefined)
113
113
114-- $setup
114-- $setup
115-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)
115-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)
@@ -166,7 +166,7 @@ showJSValue (ValObject _) = "object"
166-- >>> testJSaddle $ valToBool "1"
166-- >>> testJSaddle $ valToBool "1"
167-- true
167-- true
168valToBool :: ToJSVal value => value -> JSM Bool
168valToBool :: ToJSVal value => value -> JSM Bool
169−valToBool value = toJSVal value >>= isTruthyIO
169+valToBool value = toJSVal value >>= ghcjsPure . isTruthy
170
170
171-- | Given a JavaScript value get its numeric value.
171-- | Given a JavaScript value get its numeric value.
172-- May throw JSException.
172-- May throw JSException.
@@ -192,10 +192,7 @@ valToNumber :: ToJSVal value => value -> JSM Double
192valToNumber value = jsrefToNumber <$> toJSVal value
192valToNumber value = jsrefToNumber <$> toJSVal value
193foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
193foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double
194#else
194#else
195−valToNumber value =
195+valToNumber value = toJSVal value >>= valueToNumber
196− withToJSVal value $ \rval -> do
197− ~(ValueToNumberResult result) <- sendCommand (ValueToNumber rval)
198− return result
199#endif
196#endif
200
197
201-- | Given a JavaScript value get its string value (as a JavaScript string).
198-- | Given a JavaScript value get its string value (as a JavaScript string).
@@ -222,10 +219,7 @@ valToStr :: ToJSVal value => value -> JSM JSString
222valToStr value = jsrefToString <$> toJSVal value
219valToStr value = jsrefToString <$> toJSVal value
223foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
220foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString
224#else
221#else
225−valToStr value =
222+valToStr value = toJSVal value >>= valueToString
226− withToJSVal value $ \rval -> do
227− ~(ValueToStringResult result) <- sendCommand (ValueToString rval)
228− wrapJSString result
229#endif
223#endif
230
224
231-- | Given a JavaScript value get its string value (as a Haskell 'Text').
225-- | Given a JavaScript value get its string value (as a Haskell 'Text').
@@ -276,10 +270,7 @@ valToJSON :: ToJSVal value => value -> JSM JSString
276valToJSON value = jsrefToJSON <$> toJSVal value
270valToJSON value = jsrefToJSON <$> toJSVal value
277foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
271foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString
278#else
272#else
279−valToJSON value =
273+valToJSON value = toJSVal value >>= valueToJSON
280− withToJSVal value $ \rval -> do
281− ~(ValueToJSONResult result) <- sendCommand (ValueToJSON rval)
282− wrapJSString result
283#endif
274#endif
284
275
285-- | Given a JavaScript value get its object value.
276-- | Given a JavaScript value get its object value.
@@ -305,7 +296,7 @@ valToObject :: ToJSVal value => value -> JSM Object
305valToObject value = Object <$> toJSVal value
296valToObject value = Object <$> toJSVal value
306
297
307instance MakeObject JSVal where
298instance MakeObject JSVal where
308− makeObject = valToObject
299+ makeObject = return . Object
309
300
310instance ToJSVal Object where
301instance ToJSVal Object where
311 toJSVal (Object r) = return r
302 toJSVal (Object r) = return r
@@ -356,16 +347,16 @@ instance ToJSVal a => ToJSVal (Maybe a) where
356 {-# INLINE toJSVal #-}
347 {-# INLINE toJSVal #-}
357instance FromJSVal a => FromJSVal (Maybe a) where
348instance FromJSVal a => FromJSVal (Maybe a) where
358 fromJSValUnchecked x =
349 fromJSValUnchecked x =
359− isUndefinedIO x >>= \case
350+ ghcjsPure (isUndefined x) >>= \case
360 True -> return Nothing
351 True -> return Nothing
361− False -> isNullIO x >>= \case
352+ False -> ghcjsPure (isNull x) >>= \case
362 True -> return Nothing
353 True -> return Nothing
363 False -> fromJSVal x
354 False -> fromJSVal x
364 {-# INLINE fromJSValUnchecked #-}
355 {-# INLINE fromJSValUnchecked #-}
365 fromJSVal x =
356 fromJSVal x =
366− isUndefinedIO x >>= \case
357+ ghcjsPure (isUndefined x) >>= \case
367 True -> return (Just Nothing)
358 True -> return (Just Nothing)
368− False -> isNullIO x >>= \case
359+ False -> ghcjsPure (isNull x) >>= \case
369 True -> return (Just Nothing)
360 True -> return (Just Nothing)
370 False -> fmap (fmap Just) fromJSVal x
361 False -> fmap (fmap Just) fromJSVal x
371 {-# INLINE fromJSVal #-}
362 {-# INLINE fromJSVal #-}
@@ -382,7 +373,7 @@ instance FromJSVal a => FromJSVal [a] where
382
373
383-- | Test a JavaScript value to see if it is @null@
374-- | Test a JavaScript value to see if it is @null@
384valIsNull :: ToJSVal value => value -> JSM Bool
375valIsNull :: ToJSVal value => value -> JSM Bool
385−valIsNull value = toJSVal value >>= isNullIO
376+valIsNull value = toJSVal value >>= ghcjsPure . isNull
386
377
387----------- undefined ---------------
378----------- undefined ---------------
388-- | An @undefined@ JavaScript value
379-- | An @undefined@ JavaScript value
@@ -405,26 +396,26 @@ instance MakeArgs () where
405
396
406-- | Test a JavaScript value to see if it is @undefined@
397-- | Test a JavaScript value to see if it is @undefined@
407valIsUndefined :: ToJSVal value => value -> JSM Bool
398valIsUndefined :: ToJSVal value => value -> JSM Bool
408−valIsUndefined value = toJSVal value >>= isUndefinedIO
399+valIsUndefined value = toJSVal value >>= ghcjsPure . isUndefined
409
400
410-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)
401-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)
411maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
402maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)
412maybeNullOrUndefined value = do
403maybeNullOrUndefined value = do
413 rval <- toJSVal value
404 rval <- toJSVal value
414− valIsNull rval >>= \case
405+ ghcjsPure (isNull rval) >>= \case
415 True -> return Nothing
406 True -> return Nothing
416 _ ->
407 _ ->
417− valIsUndefined rval >>= \case
408+ ghcjsPure (isUndefined rval) >>= \case
418 True -> return Nothing
409 True -> return Nothing
419 _ -> return (Just rval)
410 _ -> return (Just rval)
420
411
421maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
412maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)
422maybeNullOrUndefined' f value = do
413maybeNullOrUndefined' f value = do
423 rval <- toJSVal value
414 rval <- toJSVal value
424− valIsNull rval >>= \case
415+ ghcjsPure (isNull rval) >>= \case
425 True -> return Nothing
416 True -> return Nothing
426 _ ->
417 _ ->
427− valIsUndefined rval >>= \case
418+ ghcjsPure (isUndefined rval) >>= \case
428 True -> return Nothing
419 True -> return Nothing
429 _ -> Just <$> f rval
420 _ -> Just <$> f rval
430
421
@@ -448,52 +439,49 @@ instance MakeArgs Bool where
448----------- numbers ---------------
439----------- numbers ---------------
449-- | Make a JavaScript number
440-- | Make a JavaScript number
450valMakeNumber :: Double -> JSM JSVal
441valMakeNumber :: Double -> JSM JSVal
451−#ifdef ghcjs_HOST_OS
452−valMakeNumber n = toJSVal n
442+valMakeNumber = toJSVal
453−#else
443+{-# INLINE valMakeNumber #-}
454−valMakeNumber = sendLazyCommand . NumberToValue
455−#endif
456
444
457#ifndef ghcjs_HOST_OS
445#ifndef ghcjs_HOST_OS
458-- | Makes a JavaScript number
446-- | Makes a JavaScript number
459instance ToJSVal Double where
447instance ToJSVal Double where
460− toJSVal = valMakeNumber
448+ toJSVal = numberToValue
461 {-# INLINE toJSVal #-}
449 {-# INLINE toJSVal #-}
462
450
463instance ToJSVal Float where
451instance ToJSVal Float where
464− toJSVal = valMakeNumber . realToFrac
452+ toJSVal = numberToValue . realToFrac
465 {-# INLINE toJSVal #-}
453 {-# INLINE toJSVal #-}
466
454
467instance ToJSVal Word where
455instance ToJSVal Word where
468− toJSVal = valMakeNumber . fromIntegral
456+ toJSVal = numberToValue . fromIntegral
469 {-# INLINE toJSVal #-}
457 {-# INLINE toJSVal #-}
470
458
471instance ToJSVal Word8 where
459instance ToJSVal Word8 where
472− toJSVal = valMakeNumber . fromIntegral
460+ toJSVal = numberToValue . fromIntegral
473 {-# INLINE toJSVal #-}
461 {-# INLINE toJSVal #-}
474
462
475instance ToJSVal Word16 where
463instance ToJSVal Word16 where
476− toJSVal = valMakeNumber . fromIntegral
464+ toJSVal = numberToValue . fromIntegral
477 {-# INLINE toJSVal #-}
465 {-# INLINE toJSVal #-}
478
466
479instance ToJSVal Word32 where
467instance ToJSVal Word32 where
480− toJSVal = valMakeNumber . fromIntegral
468+ toJSVal = numberToValue . fromIntegral
481 {-# INLINE toJSVal #-}
469 {-# INLINE toJSVal #-}
482
470
483instance ToJSVal Int where
471instance ToJSVal Int where
484− toJSVal = valMakeNumber . fromIntegral
472+ toJSVal = numberToValue . fromIntegral
485 {-# INLINE toJSVal #-}
473 {-# INLINE toJSVal #-}
486
474
487instance ToJSVal Int8 where
475instance ToJSVal Int8 where
488− toJSVal = valMakeNumber . fromIntegral
476+ toJSVal = numberToValue . fromIntegral
489 {-# INLINE toJSVal #-}
477 {-# INLINE toJSVal #-}
490
478
491instance ToJSVal Int16 where
479instance ToJSVal Int16 where
492− toJSVal = valMakeNumber . fromIntegral
480+ toJSVal = numberToValue . fromIntegral
493 {-# INLINE toJSVal #-}
481 {-# INLINE toJSVal #-}
494
482
495instance ToJSVal Int32 where
483instance ToJSVal Int32 where
496− toJSVal = valMakeNumber . fromIntegral
484+ toJSVal = numberToValue . fromIntegral
497 {-# INLINE toJSVal #-}
485 {-# INLINE toJSVal #-}
498#endif
486#endif
499
487
@@ -503,25 +491,18 @@ instance MakeArgs Double where
503
491
504-- | Make a JavaScript string from `Text`
492-- | Make a JavaScript string from `Text`
505valMakeText :: Text -> JSM JSVal
493valMakeText :: Text -> JSM JSVal
506−#ifdef ghcjs_HOST_OS
507−valMakeText = return . pToJSVal . textToJSString
494+valMakeText = toJSVal . textToJSString
508−#else
495+{-# INLINE valMakeText #-}
509−valMakeText text = valMakeString (textToStr text)
510−#endif
511
496
512-- | Make a JavaScript string from `JSString`
497-- | Make a JavaScript string from `JSString`
513valMakeString :: JSString -> JSM JSVal
498valMakeString :: JSString -> JSM JSVal
514−#ifdef ghcjs_HOST_OS
515−valMakeString = return . pToJSVal
499+valMakeString = toJSVal
516−#else
500+{-# INLINE valMakeString #-}
517−valMakeString s =
518− withJSString s $ sendLazyCommand . StringToValue
519−#endif
520
501
521#ifndef ghcjs_HOST_OS
502#ifndef ghcjs_HOST_OS
522-- | Makes a JavaScript string
503-- | Makes a JavaScript string
523instance ToJSVal Text where
504instance ToJSVal Text where
524− toJSVal = valMakeText
505+ toJSVal = stringToValue . JSString
525 {-# INLINE toJSVal #-}
506 {-# INLINE toJSVal #-}
526instance FromJSVal Text where
507instance FromJSVal Text where
527 fromJSValUnchecked = valToText
508 fromJSValUnchecked = valToText
@@ -537,7 +518,7 @@ instance MakeArgs Text where
537#ifndef ghcjs_HOST_OS
518#ifndef ghcjs_HOST_OS
538-- | Makes a JavaScript string
519-- | Makes a JavaScript string
539instance ToJSVal JSString where
520instance ToJSVal JSString where
540− toJSVal = valMakeString
521+ toJSVal = stringToValue
541 {-# INLINE toJSVal #-}
522 {-# INLINE toJSVal #-}
542instance FromJSVal JSString where
523instance FromJSVal JSString where
543 fromJSValUnchecked = valToStr
524 fromJSValUnchecked = valToStr
@@ -584,16 +565,12 @@ instance FromJSVal Char where
584
565
585-- | Make a JavaScript string from AESON `Value`
566-- | Make a JavaScript string from AESON `Value`
586valMakeJSON :: Value -> JSM JSVal
567valMakeJSON :: Value -> JSM JSVal
587−#ifdef ghcjs_HOST_OS
588valMakeJSON = toJSVal
568valMakeJSON = toJSVal
589−#else
590−valMakeJSON = sendLazyCommand . JSONValueToValue
591−#endif
592
569
593#ifndef ghcjs_HOST_OS
570#ifndef ghcjs_HOST_OS
594-- | Makes a JSON value
571-- | Makes a JSON value
595instance ToJSVal Value where
572instance ToJSVal Value where
596− toJSVal = valMakeJSON
573+ toJSVal = jsonValueToValue
597 {-# INLINE toJSVal #-}
574 {-# INLINE toJSVal #-}
598#endif
575#endif
599
576
@@ -642,19 +619,16 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\
642 (typeof $1===\"string\")?4:\
619 (typeof $1===\"string\")?4:\
643 (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int
620 (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int
644#else
621#else
645−deRefVal value = do
622+deRefVal value = toJSVal value >>= N.deRefVal >>= \result -> return $
646− v <- toJSVal value
647− withJSVal v $ \rval ->
648− sendCommand (DeRefVal rval) >>= \result -> return $
649− case result of
623+ case result of
650− DeRefValResult 0 _ -> ValNull
624+ DeRefValResult 0 _ -> ValNull
651− DeRefValResult 1 _ -> ValUndefined
625+ DeRefValResult 1 _ -> ValUndefined
652− DeRefValResult 2 _ -> ValBool False
626+ DeRefValResult 2 _ -> ValBool False
653− DeRefValResult 3 _ -> ValBool True
627+ DeRefValResult 3 _ -> ValBool True
654− DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
628+ DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
655− DeRefValResult (-2) s -> ValString s
629+ DeRefValResult (-2) s -> ValString s
656− DeRefValResult ref _ -> ValObject (Object (JSVal ref))
630+ DeRefValResult ref _ -> ValObject (Object (JSVal ref))
657− _ -> error "Unexpected result dereferencing JSaddle value"
631+ _ -> error "Unexpected result dereferencing JSaddle value"
658#endif
632#endif
659
633
660-- | Make a JavaScript value out of a 'JSValue' ADT.
634-- | Make a JavaScript value out of a 'JSValue' ADT.
@@ -713,10 +687,7 @@ strictEqual a b = do
713#ifdef ghcjs_HOST_OS
687#ifdef ghcjs_HOST_OS
714 return $ jsvalueisstrictequal aval bval
688 return $ jsvalueisstrictequal aval bval
715#else
689#else
716− withJSVal aval $ \aref ->
690+ N.strictEqual aval bval
717− withJSVal bval $ \bref -> do
718− ~(StrictEqualResult result) <- sendCommand $ StrictEqual aref bref
719− return result
720#endif
691#endif
721
692
722#ifdef ghcjs_HOST_OS
693#ifdef ghcjs_HOST_OS
@@ -734,10 +705,7 @@ instanceOf value constructor = do
734#ifdef ghcjs_HOST_OS
705#ifdef ghcjs_HOST_OS
735 return $ js_isInstanceOf v c
706 return $ js_isInstanceOf v c
736#else
707#else
737− withJSVal v $ \rval ->
708+ N.instanceOf v c
738− withObject c $ \c' -> do
739− ~(InstanceOfResult result) <- sendCommand $ InstanceOf rval c'
740− return result
741#endif
709#endif
742
710
743
711