ghcjs-base (empty) → 0.2.0.0
raw patch · 96 files changed
+16320/−0 lines, 96 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, array, attoparsec, base, binary, bytestring, containers, deepseq, directory, dlist, ghc-prim, ghcjs-base, ghcjs-prim, hashable, integer-gmp, primitive, quickcheck-unicode, random, scientific, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, unordered-containers, vector
Files
- Data/JSString.hs +1963/−0
- Data/JSString/Int.hs +270/−0
- Data/JSString/Internal.hs +74/−0
- Data/JSString/Internal/Fusion.hs +194/−0
- Data/JSString/Internal/Fusion/CaseMapping.hs +570/−0
- Data/JSString/Internal/Fusion/Common.hs +936/−0
- Data/JSString/Internal/Fusion/Types.hs +121/−0
- Data/JSString/Internal/Search.hs +22/−0
- Data/JSString/Internal/Type.hs +119/−0
- Data/JSString/Raw.hs +153/−0
- Data/JSString/Read.hs +171/−0
- Data/JSString/RealFloat.hs +99/−0
- Data/JSString/RegExp.hs +113/−0
- Data/JSString/Text.hs +78/−0
- GHCJS/Buffer.hs +228/−0
- GHCJS/Buffer/Types.hs +11/−0
- GHCJS/Concurrent.hs +132/−0
- GHCJS/Foreign.hs +173/−0
- GHCJS/Foreign/Callback.hs +161/−0
- GHCJS/Foreign/Callback/Internal.hs +12/−0
- GHCJS/Foreign/Export.hs +90/−0
- GHCJS/Foreign/Internal.hs +417/−0
- GHCJS/Internal/Types.hs +47/−0
- GHCJS/Marshal.hs +305/−0
- GHCJS/Marshal/Internal.hs +260/−0
- GHCJS/Marshal/Pure.hs +154/−0
- GHCJS/Nullable.hs +19/−0
- GHCJS/Types.hs +66/−0
- JavaScript/Array.hs +111/−0
- JavaScript/Array/Internal.hs +193/−0
- JavaScript/Array/ST.hs +112/−0
- JavaScript/Cast.hs +26/−0
- JavaScript/JSON.hs +12/−0
- JavaScript/JSON/Types.hs +80/−0
- JavaScript/JSON/Types/Class.hs +37/−0
- JavaScript/JSON/Types/Generic.hs +618/−0
- JavaScript/JSON/Types/Instances.hs +1088/−0
- JavaScript/JSON/Types/Internal.hs +328/−0
- JavaScript/Number.hs +2/−0
- JavaScript/Object.hs +80/−0
- JavaScript/Object/Internal.hs +91/−0
- JavaScript/RegExp.hs +5/−0
- JavaScript/TypedArray.hs +19/−0
- JavaScript/TypedArray/ArrayBuffer.hs +48/−0
- JavaScript/TypedArray/ArrayBuffer/Internal.hs +53/−0
- JavaScript/TypedArray/ArrayBuffer/ST.hs +35/−0
- JavaScript/TypedArray/DataView.hs +338/−0
- JavaScript/TypedArray/DataView/Internal.hs +147/−0
- JavaScript/TypedArray/DataView/ST.hs +232/−0
- JavaScript/TypedArray/Internal.hs +536/−0
- JavaScript/TypedArray/Internal/Types.hs +120/−0
- JavaScript/TypedArray/ST.hs +120/−0
- JavaScript/Web/AnimationFrame.hs +75/−0
- JavaScript/Web/Blob.hs +10/−0
- JavaScript/Web/Blob/Internal.hs +55/−0
- JavaScript/Web/Canvas.hs +433/−0
- JavaScript/Web/Canvas/ImageData.hs +33/−0
- JavaScript/Web/Canvas/Internal.hs +28/−0
- JavaScript/Web/Canvas/TextMetrics.hs +94/−0
- JavaScript/Web/CloseEvent.hs +32/−0
- JavaScript/Web/CloseEvent/Internal.hs +10/−0
- JavaScript/Web/ErrorEvent.hs +51/−0
- JavaScript/Web/ErrorEvent/Internal.hs +9/−0
- JavaScript/Web/File.hs +31/−0
- JavaScript/Web/History.hs +3/−0
- JavaScript/Web/Location.hs +172/−0
- JavaScript/Web/MessageEvent.hs +43/−0
- JavaScript/Web/MessageEvent/Internal.hs +9/−0
- JavaScript/Web/Performance.hs +31/−0
- JavaScript/Web/Storage.hs +74/−0
- JavaScript/Web/Storage/Internal.hs +10/−0
- JavaScript/Web/StorageEvent.hs +62/−0
- JavaScript/Web/WebSocket.hs +190/−0
- JavaScript/Web/Worker.hs +35/−0
- JavaScript/Web/XMLHttpRequest.hs +256/−0
- LICENSE +7/−0
- Setup.hs +2/−0
- ghcjs-base.cabal +175/−0
- jsbits/animationFrame.js +18/−0
- jsbits/array.js +40/−0
- jsbits/export.js +26/−0
- jsbits/foreign.js +8/−0
- jsbits/jsstring.js +1181/−0
- jsbits/jsstringRaw.js +21/−0
- jsbits/text.js +53/−0
- jsbits/utils.js +93/−0
- jsbits/websocket.js +58/−0
- jsbits/xhr.js +16/−0
- test/Tests.hs +15/−0
- test/Tests/Marshal.hs +91/−0
- test/Tests/Properties.hs +795/−0
- test/Tests/Properties/Numeric.hs +81/−0
- test/Tests/QuickCheckUtils.hs +328/−0
- test/Tests/Regressions.hs +86/−0
- test/Tests/SlowFunctions.hs +39/−0
- test/Tests/Utils.hs +52/−0
+ Data/JSString.hs view
@@ -0,0 +1,1963 @@+{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies,+ ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes,+ GHCForeignImportPrim, CPP+ #-}+{-| Manipulation of JavaScript strings, API and fusion implementation+ based on Data.Text by Tom Harper, Duncan Coutts, Bryan O'Sullivan e.a.+ -}+module Data.JSString ( JSString++ -- * Creation and elimination+ , pack+ , unpack, unpack'+ , singleton+ , empty++ -- * Basic interface+ , cons+ , snoc+ , append+ , uncons+ , unsnoc+ , head+ , last+ , tail+ , init+ , null+ , length+ , compareLength++ -- * Transformations+ , map+ , intercalate+ , intersperse+ , transpose+ , reverse+ , replace++ -- ** Case conversion+ , toCaseFold+ , toLower+ , toUpper+ , toTitle++ -- ** Justification+ , justifyLeft+ , justifyRight+ , center++ -- * Folds+ , foldl+ , foldl'+ , foldl1+ , foldl1'+ , foldr+ , foldr1++ -- ** Special folds+ , concat+ , concatMap+ , any+ , all+ , maximum+ , minimum++ -- * Construction++ -- ** Scans+ , scanl+ , scanl1+ , scanr+ , scanr1++ -- ** Accumulating maps+ , mapAccumL+ , mapAccumR++ -- ** Generation and unfolding+ , replicate+ , unfoldr+ , unfoldrN++ -- * Substrings++ -- ** Breaking strings+ , take+ , takeEnd+ , drop+ , dropEnd+ , takeWhile+ , takeWhileEnd+ , dropWhile+ , dropWhileEnd+ , dropAround+ , strip+ , stripStart+ , stripEnd+ , splitAt+ , breakOn+ , breakOnEnd+ , break+ , span+ , group+ , group'+ , groupBy+ , inits+ , tails++ -- ** Breaking into many substrings+ , splitOn, splitOn'+ , split+ , chunksOf, chunksOf'++ -- ** Breaking into lines and words+ , lines, lines'+ , words, words'+ , unlines+ , unwords++ -- * Predicates+ , isPrefixOf+ , isSuffixOf+ , isInfixOf++ -- ** View patterns+ , stripPrefix+ , stripSuffix+ , commonPrefixes++ -- * Searching+ , filter+ , breakOnAll, breakOnAll'+ , find+ , partition++ -- * Indexing+ , index+ , findIndex+ , count++ -- * Zipping+ , zip+ , zipWith+ ) where++import Prelude+ ( Char, Bool(..), Int, Maybe(..), String, Eq(..), Ord(..), Ordering(..), (++)+ , Read(..), Show(..), (&&), (||), (+), (-), (.), ($), ($!), (>>)+ , not, seq, return, otherwise, quot)+import qualified Prelude as P++import Control.DeepSeq (NFData(..))+import Data.Binary (Binary(..))+import Data.Char (isSpace)+import qualified Data.List as L+import Data.Data++import GHC.Exts+ ( Int#, (+#), (-#), (>=#), (>#), isTrue#, chr#, Char(..)+ , Int(..), Addr#, tagToEnum#)+import qualified GHC.Exts as Exts+import qualified GHC.CString as GHC+import qualified GHC.Base as GHC++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup(..))+#endif++import Unsafe.Coerce++import GHCJS.Prim (JSVal)+import qualified GHCJS.Prim as Prim++import Data.JSString.Internal.Type+import Data.JSString.Internal.Fusion (stream, unstream)+import qualified Data.JSString.Internal.Fusion as S+import qualified Data.JSString.Internal.Fusion.Common as S++import Text.Printf (PrintfArg(..), formatString)++getJSVal :: JSString -> JSVal+getJSVal (JSString x) = x+{-# INLINE getJSVal #-}++instance Exts.IsString JSString where+ fromString = pack++instance Exts.IsList JSString where+ type Item JSString = Char+ fromList = pack+ toList = unpack++#if MIN_VERSION_base(4,9,0)+instance Semigroup JSString where+ (<>) = append+#endif++instance P.Monoid JSString where+ mempty = empty+#if MIN_VERSION_base(4,9,0)+ mappend = (<>) -- future-proof definition+#else+ mappend = append+#endif+ mconcat = concat++instance Eq JSString where+ x == y = js_eq x y++{-+instance Binary JSString where+ put jss = put (encodeUtf8 jss)+ get = do+ bs <- get+ case decodeUtf8' bs of+ P.Left exn -> P.fail (P.show exn)+ P.Right a -> P.pure a+-}++#if MIN_VERSION_base(4,7,0)+instance PrintfArg JSString where+ formatArg txt = formatString $ unpack txt+#endif++instance Ord JSString where+ compare x y = compareStrings x y++equals :: JSString -> JSString -> Bool+equals x y = js_eq x y+{-# INLINE equals #-}++compareStrings :: JSString -> JSString -> Ordering+compareStrings x y = tagToEnum# (js_compare x y +# 1#)+{-# INLINE compareStrings #-}++-- | This instance preserves data abstraction at the cost of inefficiency.+-- See Data.Text for more information+instance Data JSString where+ gfoldl f z txt = z pack `f` (unpack txt)+ toConstr _ = packConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z pack)+ _ -> P.error "gunfold"+ dataTypeOf _ = jsstringDataType++packConstr :: Constr+packConstr = mkConstr jsstringDataType "pack" [] Prefix++jsstringDataType :: DataType+jsstringDataType = mkDataType "Data.JSString.JSString" [packConstr]++instance Show JSString where+ showsPrec p ps r = showsPrec p (unpack ps) r++instance Read JSString where+ readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]++-- -----------------------------------------------------------------------------+-- * Conversion to/from 'JSString'++-- | /O(n)/ Convert a 'String' into a 'JSString'. Subject to+-- fusion.+pack :: String -> JSString+pack x = rnf x `seq` js_pack (unsafeCoerce x)+{-# INLINE [1] pack #-}++{-# RULES+"JSSTRING pack -> fused" [~1] forall x.+ pack x = unstream (S.map safe (S.streamList x))+"JSSTRING pack -> unfused" [1] forall x.+ unstream (S.map safe (S.streamList x)) = pack x+ #-}++-- | /O(n)/ Convert a 'JSString' into a 'String'. Subject to fusion.+unpack :: JSString -> String+unpack = S.unstreamList . stream+{-# INLINE [1] unpack #-}++unpack' :: JSString -> String+unpack' x = unsafeCoerce (js_unpack x)+{-# INLINE unpack' #-}++-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion.+unpackCString# :: Addr# -> JSString+unpackCString# addr# = unstream (S.streamCString# addr#)+{-# NOINLINE unpackCString# #-}++{-# RULES "JSSTRING literal" forall a.+ unstream (S.map safe (S.streamList (GHC.unpackCString# a)))+ = unpackCString# a #-}++{-# RULES "JSSTRING literal UTF8" forall a.+ unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a)))+ = unpackCString# a #-}++{-# RULES "JSSTRING empty literal"+ unstream (S.map safe (S.streamList []))+ = empty_ #-}++{-# RULES "JSSTRING singleton literal" forall a.+ unstream (S.map safe (S.streamList [a]))+ = singleton a #-}++#if MIN_VERSION_ghcjs_prim(0,1,1)+{-# RULES "JSSTRING literal prim" [0] forall a.+ unpackCString# a = JSString (Prim.unsafeUnpackJSStringUtf8# a)+ #-}+#endif++-- | /O(1)/ Convert a character into a 'JSString'. Subject to fusion.+-- Performs replacement on invalid scalar values.+singleton :: Char -> JSString+singleton c = js_singleton c -- unstream . S.singleton . safe+{-# INLINE [1] singleton #-}++{-# RULES+"JSSTRING singleton -> fused" [~1] forall a.+ singleton a = unstream (S.singleton (safe a))+"JSSTRING singleton -> unfused" [1] forall a.+ unstream (S.singleton (safe a)) = singleton a+ #-}++-- This is intended to reduce inlining bloat.+-- singleton_ :: Char -> Text+-- singleton_ c = js_singleton c++-- Text (A.run x) 0 len+-- where x :: ST s (A.MArray s)+-- x = do arr <- A.new len+-- _ <- unsafeWrite arr 0 d+-- return arr+-- len | d < '\x10000' = 1+-- x | otherwise = 2+-- d = safe c+-- {-# NOINLINE singleton_ #-}++-- -----------------------------------------------------------------------------+-- * Basic functions++-- | /O(n)/ Adds a character to the front of a 'JSString'. This function+-- is more costly than its 'List' counterpart because it requires+-- copying a new array. Subject to fusion. Performs replacement on+-- invalid scalar values.+cons :: Char -> JSString -> JSString+cons c x = js_cons c x+{-# INLINE [1] cons #-}++{-# RULES+"JSSTRING cons -> fused" [~1] forall c x.+ cons c x = unstream (S.cons (safe c) (stream x))+"JSSTRING cons -> unfused" [1] forall c x.+ unstream (S.cons (safe c) (stream x)) = cons c x+ #-}++infixr 5 `cons`++-- | /O(n)/ Adds a character to the end of a 'JSString'. This copies the+-- entire array in the process, unless fused. Subject to fusion.+-- Performs replacement on invalid scalar values.+snoc :: JSString -> Char -> JSString+snoc x c = js_snoc x c+ -- unstream (S.snoc (stream t) (safe c))+{-# INLINE [1] snoc #-}++{-# RULES+"JSSTRING snoc -> fused" [~1] forall x c.+ snoc x c = unstream (S.snoc (stream x) (safe c))+"JSSTRING snoc -> unfused" [1] forall x c.+ unstream (S.snoc (stream x) (safe c)) = snoc x c+ #-}++-- | /O(n)/ Appends one 'JSString' to the other by copying both of them+-- into a new 'JSString'. Subject to fusion.+append :: JSString -> JSString -> JSString+append x y = js_append x y+{-# INLINE [1] append #-}++{-# RULES+"JSSTRING append -> fused" [~1] forall x1 x2.+ append x1 x2 = unstream (S.append (stream x1) (stream x2))+"JSSTRING append -> unfused" [1] forall x1 x2.+ unstream (S.append (stream x1) (stream x2)) = append x1 x2+ #-}++-- | /O(1)/ Returns the first character of a 'JSString', which must be+-- non-empty. Subject to fusion.+head :: JSString -> Char+head x = case js_head x of+ -1# -> emptyError "head"+ ch -> C# (chr# ch)+{-# INLINE [1] head #-}++{-# RULES+"JSSTRING head -> fused" [~1] forall x.+ head x = S.head (stream x)+"JSSTRING head -> unfused" [1] forall x.+ S.head (stream x) = head x+ #-}+++-- | /O(1)/ Returns the first character and rest of a 'JSString', or+-- 'Nothing' if empty. Subject to fusion.+uncons :: JSString -> Maybe (Char, JSString)+uncons x = case js_uncons x of+ (# -1#, _ #) -> Nothing+ (# cp, t #) -> Just (C# (chr# cp), t)+{-# INLINE [1] uncons #-}++unsnoc :: JSString -> Maybe (JSString, Char)+unsnoc x = case js_unsnoc x of+ (# -1#, _ #) -> Nothing+ (# cp, t #) -> Just (t, C# (chr# cp))+{-# INLINE [1] unsnoc #-}++-- | Lifted from Control.Arrow and specialized.+second :: (b -> c) -> (a,b) -> (a,c)+second f (a, b) = (a, f b)++-- | /O(1)/ Returns the last character of a 'JSString', which must be+-- non-empty. Subject to fusion.+last :: JSString -> Char+last x = case js_last x of+ -1# -> emptyError "last"+ c -> (C# (chr# c))+{-# INLINE [1] last #-}++{-# RULES+"JSSTRING last -> fused" [~1] forall x.+ last x = S.last (stream x)+"JSSTRING last -> unfused" [1] forall x.+ S.last (stream x) = last x+ #-}++-- | /O(1)/ Returns all characters after the head of a 'JSString', which+-- must be non-empty. Subject to fusion.+tail :: JSString -> JSString+tail x =+ let r = js_tail x+ in if js_isNull r+ then emptyError "tail"+ else JSString r+{-# INLINE [1] tail #-}++{-# RULES+"JSSTRING tail -> fused" [~1] forall x.+ tail x = unstream (S.tail (stream x))+"JSSTRING tail -> unfused" [1] forall x.+ unstream (S.tail (stream x)) = tail x+ #-}++-- | /O(1)/ Returns all but the last character of a 'JSString', which must+-- be non-empty. Subject to fusion.+init :: JSString -> JSString+init x =+ let r = js_init x+ in if js_isNull r+ then emptyError "init"+ else JSString r+{-# INLINE [1] init #-}++{-# RULES+"JSSTRING init -> fused" [~1] forall t.+ init t = unstream (S.init (stream t))+"JSSTRING init -> unfused" [1] forall t.+ unstream (S.init (stream t)) = init t+ #-}++-- | /O(1)/ Tests whether a 'JSString' is empty or not. Subject to+-- fusion.+null :: JSString -> Bool+null x = js_null x+{-# INLINE [1] null #-}++{-# RULES+"JSSTRING null -> fused" [~1] forall t.+ null t = S.null (stream t)+"JSSTRING null -> unfused" [1] forall t.+ S.null (stream t) = null t+ #-}++-- | /O(1)/ Tests whether a 'JSString' contains exactly one character.+-- Subject to fusion.+isSingleton :: JSString -> Bool+isSingleton x = js_isSingleton x+{-# INLINE [1] isSingleton #-}++{-# RULES+"JSSTRING isSingleton -> fused" [~1] forall x.+ isSingleton x = S.isSingleton (stream x)+"JSSTRING isSingleton -> unfused" [1] forall x.+ S.isSingleton (stream x) = isSingleton x+ #-}++-- | /O(n)/ Returns the number of characters in a 'JSString'.+-- Subject to fusion.+length :: JSString -> Int+length x = S.length (stream x)+{-# INLINE [0] length #-}+-- length needs to be phased after the compareN/length rules otherwise+-- it may inline before the rules have an opportunity to fire.++-- | /O(n)/ Compare the count of characters in a 'JSString' to a number.+-- Subject to fusion.+--+-- This function gives the same answer as comparing against the result+-- of 'length', but can short circuit if the count of characters is+-- greater than the number, and hence be more efficient.+compareLength :: JSString -> Int -> Ordering+compareLength t n = S.compareLengthI (stream t) n+{-# INLINE [1] compareLength #-}++{-# RULES+"JSSTRING compareN/length -> compareLength" [~1] forall t n.+ compare (length t) n = compareLength t n+ #-}++{-# RULES+"JSSTRING ==N/length -> compareLength/==EQ" [~1] forall t n.+ GHC.eqInt (length t) n = compareLength t n == EQ+ #-}++{-# RULES+"JSSTRING /=N/length -> compareLength//=EQ" [~1] forall t n.+ GHC.neInt (length t) n = compareLength t n /= EQ+ #-}++{-# RULES+"JSSTRING <N/length -> compareLength/==LT" [~1] forall t n.+ GHC.ltInt (length t) n = compareLength t n == LT+ #-}++{-# RULES+"JSSTRING <=N/length -> compareLength//=GT" [~1] forall t n.+ GHC.leInt (length t) n = compareLength t n /= GT+ #-}++{-# RULES+"JSSTRING >N/length -> compareLength/==GT" [~1] forall t n.+ GHC.gtInt (length t) n = compareLength t n == GT+ #-}++{-# RULES+"JSSTRING >=N/length -> compareLength//=LT" [~1] forall t n.+ GHC.geInt (length t) n = compareLength t n /= LT+ #-}++-- -----------------------------------------------------------------------------+-- * Transformations+-- | /O(n)/ 'map' @f@ @t@ is the 'JSString' obtained by applying @f@ to+-- each element of @t@.+--+-- Example:+--+-- >>> let message = pack "I am not angry. Not at all."+-- >>> T.map (\c -> if c == '.' then '!' else c) message+-- "I am not angry! Not at all!"+--+-- Subject to fusion. Performs replacement on invalid scalar values.+map :: (Char -> Char) -> JSString -> JSString+map f t = unstream (S.map (safe . f) (stream t))+{-# INLINE [1] map #-}++-- | /O(n)/ The 'intercalate' function takes a 'JSString' and a list of+-- 'JSString's and concatenates the list after interspersing the first+-- argument between each element of the list.+intercalate :: JSString -> [JSString] -> JSString+intercalate i xs = rnf xs `seq` js_intercalate i (unsafeCoerce xs)+{-# INLINE [1] intercalate #-}++-- | /O(n)/ The 'intersperse' function takes a character and places it+-- between the characters of a 'JSString'.+--+-- Example:+--+-- >>> T.intersperse '.' "SHIELD"+-- "S.H.I.E.L.D"+--+-- Subject to fusion. Performs replacement on invalid scalar values.+intersperse :: Char -> JSString -> JSString+intersperse c x = js_intersperse c x+{-# INLINE [1] intersperse #-}++{-# RULES+"JSSTRING intersperse -> fused" [~1] forall c x.+ intersperse c x = unstream (S.intersperse (safe c) (stream x))+"JSSTRING intersperse -> unfused" [1] forall c x.+ unstream (S.intersperse (safe c) (stream x)) = intersperse c x+ #-}++-- | /O(n)/ Reverse the characters of a string.+--+-- Example:+--+-- >>> T.reverse "desrever"+-- "reversed"+--+-- Subject to fusion.+reverse :: JSString -> JSString+reverse x = js_reverse x -- S.reverse (stream x)+{-# INLINE [1] reverse #-}++{-# RULES+"JSSTRING reverse -> fused" [~1] forall x.+ reverse x = S.reverse (stream x)+"JSSTRING reverse -> unfused" [1] forall x.+ S.reverse (stream x) = reverse x+ #-}++-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in+-- @haystack@ with @replacement@.+--+-- This function behaves as though it was defined as follows:+--+-- @+-- replace needle replacement haystack =+-- 'intercalate' replacement ('splitOn' needle haystack)+-- @+--+-- As this suggests, each occurrence is replaced exactly once. So if+-- @needle@ occurs in @replacement@, that occurrence will /not/ itself+-- be replaced recursively:+--+-- >>> replace "oo" "foo" "oo"+-- "foo"+--+-- In cases where several instances of @needle@ overlap, only the+-- first one will be replaced:+--+-- >>> replace "ofo" "bar" "ofofo"+-- "barfo"+--+-- In (unlikely) bad cases, this function's time complexity degrades+-- towards /O(n*m)/.+replace :: JSString+ -- ^ @needle@ to search for. If this string is empty, an+ -- error will occur.+ -> JSString+ -- ^ @replacement@ to replace @needle@ with.+ -> JSString+ -- ^ @haystack@ in which to search.+ -> JSString+replace needle replacement haystack+ | js_null needle = emptyError "replace"+ | otherwise = js_replace needle replacement haystack+{-# INLINE replace #-}++-- ----------------------------------------------------------------------------+-- ** Case conversions (folds)++-- $case+--+-- When case converting 'JSString' values, do not use combinators like+-- @map toUpper@ to case convert each character of a string+-- individually, as this gives incorrect results according to the+-- rules of some writing systems. The whole-string case conversion+-- functions from this module, such as @toUpper@, obey the correct+-- case conversion rules. As a result, these functions may map one+-- input character to two or three output characters. For examples,+-- see the documentation of each function.+--+-- /Note/: In some languages, case conversion is a locale- and+-- context-dependent operation. The case conversion functions in this+-- module are /not/ locale sensitive. Programs that require locale+-- sensitivity should use appropriate versions of the+-- <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 >.++-- | /O(n)/ Convert a string to folded case. Subject to fusion.+--+-- This function is mainly useful for performing caseless (also known+-- as case insensitive) string comparisons.+--+-- A string @x@ is a caseless match for a string @y@ if and only if:+--+-- @toCaseFold x == toCaseFold y@+--+-- The result string may be longer than the input string, and may+-- differ from applying 'toLower' to the input string. For instance,+-- the Armenian small ligature \"ﬓ\" (men now, U+FB13) is case+-- folded to the sequence \"մ\" (men, U+0574) followed by+-- \"ն\" (now, U+0576), while the Greek \"µ\" (micro sign,+-- U+00B5) is case folded to \"μ\" (small letter mu, U+03BC)+-- instead of itself.+toCaseFold :: JSString -> JSString+toCaseFold t = unstream (S.toCaseFold (stream t))+{-# INLINE toCaseFold #-}++-- | /O(n)/ Convert a string to lower case, using simple case+-- conversion. Subject to fusion.+--+-- The result string may be longer than the input string. For+-- instance, \"İ\" (Latin capital letter I with dot above,+-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)+-- followed by \" ̇\" (combining dot above, U+0307).+toLower :: JSString -> JSString+toLower x = js_toLower x+{-# INLINE [1] toLower #-}++{-# RULES+"JSSTRING toLower -> fused" [~1] forall x.+ toLower x = unstream (S.toLower (stream x))+"JSSTRING toLower -> unfused" [1] forall x.+ unstream (S.toLower (stream x)) = toLower x+ #-}++-- | /O(n)/ Convert a string to upper case, using simple case+-- conversion. Subject to fusion.+--+-- The result string may be longer than the input string. For+-- instance, the German \"ß\" (eszett, U+00DF) maps to the+-- two-letter sequence \"SS\".+toUpper :: JSString -> JSString+toUpper x = js_toUpper x+{-# INLINE [1] toUpper #-}++{-# RULES+"JSSTRING toUpper -> fused" [~1] forall x.+ toUpper x = unstream (S.toUpper(stream x))+"JSSTRING toUpper -> unfused" [1] forall x.+ unstream (S.toUpper (stream x)) = toUpper x+ #-}++-- | /O(n)/ Convert a string to title case, using simple case+-- conversion. Subject to fusion.+--+-- The first letter of the input is converted to title case, as is+-- every subsequent letter that immediately follows a non-letter.+-- Every letter that immediately follows another letter is converted+-- to lower case.+--+-- The result string may be longer than the input string. For example,+-- the Latin small ligature fl (U+FB02) is converted to the+-- sequence Latin capital letter F (U+0046) followed by Latin small+-- letter l (U+006C).+--+-- /Note/: this function does not take language or culture specific+-- rules into account. For instance, in English, different style+-- guides disagree on whether the book name \"The Hill of the Red+-- Fox\" is correctly title cased—but this function will+-- capitalize /every/ word.+toTitle :: JSString -> JSString+toTitle t = unstream (S.toTitle (stream t))+{-# INLINE toTitle #-}++-- | /O(n)/ Left-justify a string to the given length, using the+-- specified fill character on the right. Subject to fusion.+-- Performs replacement on invalid scalar values.+--+-- Examples:+--+-- >>> justifyLeft 7 'x' "foo"+-- "fooxxxx"+--+-- >>> justifyLeft 3 'x' "foobar"+-- "foobar"+justifyLeft :: Int -> Char -> JSString -> JSString+justifyLeft k c t+ | len >= k = t+ | otherwise = t `append` replicateChar (k-len) c+ where len = length t+{-# INLINE [1] justifyLeft #-}++{-# RULES+"JSSTRING justifyLeft -> fused" [~1] forall k c t.+ justifyLeft k c t = unstream (S.justifyLeftI k c (stream t))+"JSSTRING justifyLeft -> unfused" [1] forall k c t.+ unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t+ #-}++-- | /O(n)/ Right-justify a string to the given length, using the+-- specified fill character on the left. Performs replacement on+-- invalid scalar values.+--+-- Examples:+--+-- >>> justifyRight 7 'x' "bar"+-- "xxxxbar"+--+-- >>> justifyRight 3 'x' "foobar"+-- "foobar"+justifyRight :: Int -> Char -> JSString -> JSString+justifyRight k c t+ | len >= k = t+ | otherwise = replicateChar (k-len) c `append` t+ where len = length t+{-# INLINE justifyRight #-}++-- | /O(n)/ Center a string to the given length, using the specified+-- fill character on either side. Performs replacement on invalid+-- scalar values.+--+-- Examples:+--+-- >>> center 8 'x' "HS"+-- "xxxHSxxx"+center :: Int -> Char -> JSString -> JSString+center k c t+ | len >= k = t+ | otherwise = replicateChar l c `append` t `append` replicateChar r c+ where len = length t+ d = k - len+ r = d `quot` 2+ l = d - r+{-# INLINE center #-}++-- | /O(n)/ The 'transpose' function transposes the rows and columns+-- of its 'JSString' argument. Note that this function uses 'pack',+-- 'unpack', and the list version of transpose, and is thus not very+-- efficient.+--+-- Examples:+--+-- >>> transpose ["green","orange"]+-- ["go","rr","ea","en","ng","e"]+--+-- >>> transpose ["blue","red"]+-- ["br","le","ud","e"]+transpose :: [JSString] -> [JSString]+transpose ts = P.map pack (L.transpose (P.map unpack ts))++-- -----------------------------------------------------------------------------+-- * Reducing 'JSString's (folds)++-- | /O(n)/ 'foldl', applied to a binary operator, a starting value+-- (typically the left-identity of the operator), and a 'JSString',+-- reduces the 'JSString' using the binary operator, from left to right.+-- Subject to fusion.+foldl :: (a -> Char -> a) -> a -> JSString -> a+foldl f z t = S.foldl f z (stream t)+{-# INLINE foldl #-}++-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.+foldl' :: (a -> Char -> a) -> a -> JSString -> a+foldl' f z t = S.foldl' f z (stream t)+{-# INLINE foldl' #-}++-- | /O(n)/ A variant of 'foldl' that has no starting value argument,+-- and thus must be applied to a non-empty 'JSString'. Subject to fusion.+foldl1 :: (Char -> Char -> Char) -> JSString -> Char+foldl1 f t = S.foldl1 f (stream t)+{-# INLINE foldl1 #-}++-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.+foldl1' :: (Char -> Char -> Char) -> JSString -> Char+foldl1' f t = S.foldl1' f (stream t)+{-# INLINE foldl1' #-}++-- | /O(n)/ 'foldr', applied to a binary operator, a starting value+-- (typically the right-identity of the operator), and a 'JSString',+-- reduces the 'JSString' using the binary operator, from right to left.+-- Subject to fusion.+foldr :: (Char -> a -> a) -> a -> JSString -> a+foldr f z t = S.foldr f z (stream t)+{-# INLINE foldr #-}++-- | /O(n)/ A variant of 'foldr' that has no starting value argument,+-- and thus must be applied to a non-empty 'JSString'. Subject to+-- fusion.+foldr1 :: (Char -> Char -> Char) -> JSString -> Char+foldr1 f t = S.foldr1 f (stream t)+{-# INLINE foldr1 #-}++-- -----------------------------------------------------------------------------+-- ** Special folds++-- | /O(n)/ Concatenate a list of 'JSString's.+concat :: [JSString] -> JSString+concat xs = rnf xs `seq` js_concat (unsafeCoerce xs)+{- case ts' of+ [] -> empty+ [t] -> t+ _ -> Text (A.run go) 0 len+ where+ ts' = L.filter (not . null) ts+ len = sumP "concat" $ L.map lengthWord16 ts'+ go :: ST s (A.MArray s)+ go = do+ arr <- A.new len+ let step i (Text a o l) =+ let !j = i + l in A.copyI arr i a o j >> return j+ foldM step 0 ts' >> return arr+-}++-- | /O(n)/ Map a function over a 'JSString' that results in a 'JSString', and+-- concatenate the results.+concatMap :: (Char -> JSString) -> JSString -> JSString+concatMap f = concat . foldr ((:) . f) []+{-# INLINE concatMap #-}++-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the+-- 'JSString' @t@ satisfies the predicate @p@. Subject to fusion.+any :: (Char -> Bool) -> JSString -> Bool+any p t = S.any p (stream t)+{-# INLINE any #-}++-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the+-- 'JSString' @t@ satisify the predicate @p@. Subject to fusion.+all :: (Char -> Bool) -> JSString -> Bool+all p t = S.all p (stream t)+{-# INLINE all #-}++-- | /O(n)/ 'maximum' returns the maximum value from a 'JSString', which+-- must be non-empty. Subject to fusion.+maximum :: JSString -> Char+maximum t = S.maximum (stream t)+{-# INLINE maximum #-}++-- | /O(n)/ 'minimum' returns the minimum value from a 'JSString', which+-- must be non-empty. Subject to fusion.+minimum :: JSString -> Char+minimum t = S.minimum (stream t)+{-# INLINE minimum #-}++-- -----------------------------------------------------------------------------+-- * Building 'JSString's++-- | /O(n)/ 'scanl' is similar to 'foldl', but returns a list of+-- successive reduced values from the left. Subject to fusion.+-- Performs replacement on invalid scalar values.+--+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]+--+-- Note that+--+-- > last (scanl f z xs) == foldl f z xs.+scanl :: (Char -> Char -> Char) -> Char -> JSString -> JSString+scanl f z t = unstream (S.scanl g z (stream t))+ where g a b = safe (f a b)+{-# INLINE scanl #-}++-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting+-- value argument. Subject to fusion. Performs replacement on+-- invalid scalar values.+--+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]+scanl1 :: (Char -> Char -> Char) -> JSString -> JSString+scanl1 f x = case uncons x of+ Just (h, t) -> scanl f h t+ Nothing -> empty+{-# INLINE scanl1 #-}++-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs+-- replacement on invalid scalar values.+--+-- > scanr f v == reverse . scanl (flip f) v . reverse+scanr :: (Char -> Char -> Char) -> Char -> JSString -> JSString+scanr f z = S.reverse . S.reverseScanr g z . S.reverseStream+ where g a b = safe (f a b)+{-# INLINE scanr #-}++-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting+-- value argument. Subject to fusion. Performs replacement on+-- invalid scalar values.+scanr1 :: (Char -> Char -> Char) -> JSString -> JSString+scanr1 f t | null t = empty+ | otherwise = scanr f (last t) (init t)+{-# INLINE scanr1 #-}++-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a+-- function to each element of a 'JSString', passing an accumulating+-- parameter from left to right, and returns a final 'JSString'. Performs+-- replacement on invalid scalar values.+mapAccumL :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)+mapAccumL f z0 = S.mapAccumL g z0 . stream+ where g a b = second safe (f a b)+{-# INLINE mapAccumL #-}++-- | The 'mapAccumR' function behaves like a combination of 'map' and+-- a strict 'foldr'; it applies a function to each element of a+-- 'JSString', passing an accumulating parameter from right to left, and+-- returning a final value of this accumulator together with the new+-- 'JSString'.+-- Performs replacement on invalid scalar values.+mapAccumR :: (a -> Char -> (a,Char)) -> a -> JSString -> (a, JSString)+mapAccumR f z0 = second reverse . S.mapAccumL g z0 . S.reverseStream+ where g a b = second safe (f a b)+{-# INLINE mapAccumR #-}++-- -----------------------------------------------------------------------------+-- ** Generating and unfolding 'JSString's++-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'JSString' consisting of the input+-- @t@ repeated @n@ times.+replicate :: Int -> JSString -> JSString+replicate (I# n) t = js_replicate n t+{- t@(Text a o l)+ | n <= 0 || l <= 0 = empty+ | n == 1 = t+ | isSingleton t = replicateChar n (unsafeHead t)+ | otherwise = Text (A.run x) 0 len+ where+ len = l `mul` n+ x :: ST s (A.MArray s)+ x = do+ arr <- A.new len+ let loop !d !i | i >= n = return arr+ | otherwise = let m = d + l+ in A.copyI arr d a o m >> loop m (i+1)+ loop 0 0 -}+{-# INLINE [1] replicate #-}++{-# RULES+"JSSTRING replicate/singleton -> replicateChar" [~1] forall n c.+ replicate n (singleton c) = replicateChar n c+ #-}++-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'JSString' of length @n@ with @c@ the+-- value of every element. Subject to fusion.+replicateChar :: Int -> Char -> JSString+replicateChar n c = js_replicateChar n c+{-# INLINE [1] replicateChar #-}++{-# RULES+"JSSTRING replicateChar -> fused" [~1] forall n c.+ replicateChar n c = unstream (S.replicateCharI n (safe c))+"JSSTRING replicateChar -> unfused" [1] forall n c.+ unstream (S.replicateCharI n (safe c)) = replicateChar n c+ #-}++-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'+-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a+-- 'JSString' from a seed value. The function takes the element and+-- returns 'Nothing' if it is done producing the 'JSString', otherwise+-- 'Just' @(a,b)@. In this case, @a@ is the next 'Char' in the+-- string, and @b@ is the seed value for further production. Subject+-- to fusion. Performs replacement on invalid scalar values.+unfoldr :: (a -> Maybe (Char,a)) -> a -> JSString+unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)+{-# INLINE unfoldr #-}++-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'JSString' from a seed+-- value. However, the length of the result should be limited by the+-- first argument to 'unfoldrN'. This function is more efficient than+-- 'unfoldr' when the maximum length of the result is known and+-- correct, otherwise its performance is similar to 'unfoldr'. Subject+-- to fusion. Performs replacement on invalid scalar values.+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> JSString+unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)+{-# INLINE unfoldrN #-}++-- -----------------------------------------------------------------------------+-- * Substrings++-- | /O(n)/ 'take' @n@, applied to a 'JSString', returns the prefix of the+-- 'JSString' of length @n@, or the 'JSString' itself if @n@ is greater than+-- the length of the JSString. Subject to fusion.+take :: Int -> JSString -> JSString+take (I# n) t = js_take n t+{- t@(Text arr off len)+ | n <= 0 = empty+ | n >= len = t+ | otherwise = text arr off (iterN n t) -}+{-# INLINE [1] take #-}+{-+iterN :: Int -> JSString -> Int+iterN n t@(Text _arr _off len) = loop 0 0+ where loop !i !cnt+ | i >= len || cnt >= n = i+ | otherwise = loop (i+d) (cnt+1)+ where d = iter_ t i+-}+{-# RULES+"JSSTRING take -> fused" [~1] forall n t.+ take n t = unstream (S.take n (stream t))+"JSSTRING take -> unfused" [1] forall n t.+ unstream (S.take n (stream t)) = take n t+ #-}++-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after+-- taking @n@ characters from the end of @t@.+--+-- Examples:+--+-- >>> takeEnd 3 "foobar"+-- "bar"+--+takeEnd :: Int -> JSString -> JSString+takeEnd (I# n) x = js_takeEnd n x+{-+iterNEnd :: Int -> JSString -> Int+iterNEnd n t@(Text _arr _off len) = loop (len-1) n+ where loop i !m+ | i <= 0 = 0+ | m <= 1 = i+ | otherwise = loop (i+d) (m-1)+ where d = reverseIter_ t i+-}+-- | /O(n)/ 'drop' @n@, applied to a 'JSString', returns the suffix of the+-- 'JSString' after the first @n@ characters, or the empty 'JSString' if @n@+-- is greater than the length of the 'JSString'. Subject to fusion.+drop :: Int -> JSString -> JSString+drop (I# n) x = js_drop n x+{-# INLINE [1] drop #-}++{-# RULES+"JSSTRING drop -> fused" [~1] forall n t.+ drop n t = unstream (S.drop n (stream t))+"JSSTRING drop -> unfused" [1] forall n t.+ unstream (S.drop n (stream t)) = drop n t+ #-}++-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after+-- dropping @n@ characters from the end of @t@.+--+-- Examples:+--+-- >>> dropEnd 3 "foobar"+-- "foo"+--+dropEnd :: Int -> JSString -> JSString+dropEnd n x = js_dropEnd n x++-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'JSString',+-- returns the longest prefix (possibly empty) of elements that+-- satisfy @p@. Subject to fusion.+takeWhile :: (Char -> Bool) -> JSString -> JSString+takeWhile p x = loop 0# (js_length x)+ where loop i l | isTrue# (i >=# l) = x+ | otherwise =+ case js_index i x of+ c | p (C# (chr# c)) -> loop (i +# charWidth c) l+ _ -> js_substr 0# i x+{-# INLINE [1] takeWhile #-}++{-# RULES+"TEXT takeWhile -> fused" [~1] forall p t.+ takeWhile p t = unstream (S.takeWhile p (stream t))+"TEXT takeWhile -> unfused" [1] forall p t.+ unstream (S.takeWhile p (stream t)) = takeWhile p t+ #-}++-- | /O(n)/ 'takeWhileEnd', applied to a predicate @p@ and a 'Text',+-- returns the longest suffix (possibly empty) of elements that+-- satisfy @p@.+-- Examples:+--+-- >>> takeWhileEnd (=='o') "foo"+-- "oo"+--+takeWhileEnd :: (Char -> Bool) -> JSString -> JSString+takeWhileEnd p x = loop (js_length x -# 1#)+ where loop -1# = empty+ loop i = case js_uncheckedIndexR i x of+ c | p (C# (chr# c)) -> loop (i -# charWidth c)+ _ -> js_substr1 (i +# 1#) x+{-# INLINE takeWhileEnd #-}++-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after+-- 'takeWhile' @p@ @t@. Subject to fusion.+dropWhile :: (Char -> Bool) -> JSString -> JSString+dropWhile p x = loop 0# (js_length x)+ where loop i l | isTrue# (i >=# l) = empty+ | otherwise =+ case js_uncheckedIndex i x of+ c | p (C# (chr# c)) -> loop (i +# charWidth c) l+ _ -> js_substr1 i x+{-# INLINE [1] dropWhile #-}++{-# RULES+"TEXT dropWhile -> fused" [~1] forall p t.+ dropWhile p t = unstream (S.dropWhile p (stream t))+"TEXT dropWhile -> unfused" [1] forall p t.+ unstream (S.dropWhile p (stream t)) = dropWhile p t+ #-}++-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after+-- dropping characters that satisfy the predicate @p@ from the end of+-- @t@. Subject to fusion.+-- Examples:+--+-- >>> dropWhileEnd (=='.') "foo..."+-- "foo"+dropWhileEnd :: (Char -> Bool) -> JSString -> JSString+dropWhileEnd p x = loop (js_length x -# 1#)+ where loop -1# = empty+ loop i = case js_uncheckedIndexR i x of+ c | p (C# (chr# c)) -> loop (i -# charWidth c)+ _ -> js_substr 0# (i +# 1#) x+{-# INLINE [1] dropWhileEnd #-}++{-# RULES+"TEXT dropWhileEnd -> fused" [~1] forall p t.+ dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t))+"TEXT dropWhileEnd -> unfused" [1] forall p t.+ S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t+ #-}++-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after+-- dropping characters that satisfy the predicate @p@ from both the+-- beginning and end of @t@. Subject to fusion.+dropAround :: (Char -> Bool) -> JSString -> JSString+dropAround p = dropWhile p . dropWhileEnd p+{-# INLINE [1] dropAround #-}++-- | /O(n)/ Remove leading white space from a string. Equivalent to:+--+-- > dropWhile isSpace+stripStart :: JSString -> JSString+stripStart = dropWhile isSpace+{-# INLINE [1] stripStart #-}++-- | /O(n)/ Remove trailing white space from a string. Equivalent to:+--+-- > dropWhileEnd isSpace+stripEnd :: JSString -> JSString+stripEnd = dropWhileEnd isSpace+{-# INLINE [1] stripEnd #-}++-- | /O(n)/ Remove leading and trailing white space from a string.+-- Equivalent to:+--+-- > dropAround isSpace+strip :: JSString -> JSString+strip = dropAround isSpace+{-# INLINE [1] strip #-}++-- | /O(n)/ 'splitAt' @n t@ returns a pair whose first element is a+-- prefix of @t@ of length @n@, and whose second is the remainder of+-- the string. It is equivalent to @('take' n t, 'drop' n t)@.+splitAt :: Int -> JSString -> (JSString, JSString)+splitAt (I# n) x = case js_splitAt n x of (# y, z #) -> (y, z)+{-# INLINE splitAt #-}++-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns+-- a pair whose first element is the longest prefix (possibly empty)+-- of @t@ of elements that satisfy @p@, and whose second is the+-- remainder of the list.+span :: (Char -> Bool) -> JSString -> (JSString, JSString)+span p x = case js_length x of+ 0# -> (empty, empty)+ l -> let c0 = js_uncheckedIndex 0# x+ in if p (C# (chr# c0)) then loop 0# l else (empty, x)+ where+ loop i l+ | isTrue# (i >=# l) = (x, empty)+ | otherwise =+ let c = js_uncheckedIndex i x+ in if p (C# (chr# c))+ then loop (i +# charWidth c) l+ else (js_substr 0# i x, js_substr1 i x)+{-# INLINE span #-}++-- | /O(n)/ 'break' is like 'span', but the prefix returned is+-- over elements that fail the predicate @p@.+break :: (Char -> Bool) -> JSString -> (JSString, JSString)+break p = span (not . p)+{-# INLINE break #-}++-- | /O(n)/ Group characters in a string according to a predicate.+groupBy :: (Char -> Char -> Bool) -> JSString -> [JSString]+groupBy p x =+ case js_length x of+ 0# -> []+ l -> let c0 = js_uncheckedIndex 0# x+ in loop (C# (chr# c0)) 0# (charWidth c0) l+ where+ loop b s i l+ | isTrue# (i >=# l) =+ if isTrue# (i ># s) then [js_substr1 s x] else []+ | otherwise =+ let c = js_uncheckedIndex i x+ c' = C# (chr# c)+ i' = i +# charWidth c+ in if p b c'+ then loop b s i' l+ else js_substring s i x : loop c' i i' l++{-+-- | Returns the /array/ index (in units of 'Word16') at which a+-- character may be found. This is /not/ the same as the logical+-- index returned by e.g. 'findIndex'.+findAIndexOrEnd :: (Char -> Bool) -> JSString -> Int+findAIndexOrEnd q t@(Text _arr _off len) = go 0+ where go !i | i >= len || q c = i+ | otherwise = go (i+d)+ where Iter c d = iter t i+-}++-- | /O(n)/ Group characters in a string by equality.+group :: JSString -> [JSString]+group x = group' x -- fixme, implement lazier version+{-# INLINE group #-}++group' :: JSString -> [JSString]+group' x = unsafeCoerce (js_group x)+{-# INLINE group' #-}++-- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest+-- first.+inits :: JSString -> [JSString]+inits x = empty : case js_length x of+ 0# -> []+ l -> loop (js_charWidthAt 0# x) l+ where+ loop i l+ | isTrue# (i >=# l) = [x]+ | otherwise =+ js_substr 0# i x : loop (i +# js_charWidthAt i x) l++-- | /O(n^2)/ Return all final segments of the given 'JSString', longest+-- first.+tails :: JSString -> [JSString]+tails x =+ case js_length x of -- this could be less strict+ 0# -> [empty]+ l -> loop 0# l+ where+ loop i l+ | isTrue# (i >=# l) = [empty]+ | otherwise =+ js_substr1 i x : loop (i +# js_charWidthAt i x) l++-- $split+--+-- Splitting functions in this library do not perform character-wise+-- copies to create substrings; they just construct new 'JSString's that+-- are slices of the original.++-- | /O(m+n)/ Break a 'JSString' into pieces separated by the first 'JSString'+-- argument (which cannot be empty), consuming the delimiter. An empty+-- delimiter is invalid, and will cause an error to be raised.+--+-- Examples:+--+-- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"+-- ["a","b","d","e"]+--+-- >>> splitOn "aaa" "aaaXaaaXaaaXaaa"+-- ["","X","X","X",""]+--+-- >>> splitOn "x" "x"+-- ["",""]+--+-- and+--+-- > intercalate s . splitOn s == id+-- > splitOn (singleton c) == split (==c)+--+-- (Note: the string @s@ to split on above cannot be empty.)+--+-- In (unlikely) bad cases, this function's time complexity degrades+-- towards /O(n*m)/.+splitOn :: JSString+ -- ^ String to split on. If this string is empty, an error+ -- will occur.+ -> JSString+ -- ^ Input text.+ -> [JSString]+splitOn = splitOn' -- fixme+{-+splitOn pat src+ | null pat = emptyError "splitOn"+ | otherwise = go 0#+ where+ go i = case js_splitOn1 i pat src of+ (# n, h #) -> case n of+ -1# -> []+ n' -> h : go n'+-}+{-# INLINE [1] splitOn #-}++-- RULES+-- "JSSTRING splitOn/singleton -> split/==" [~1] forall c t.+-- splitOn (singleton c) t = split (==c) t+--++splitOn' :: JSString+ -- ^ String to split on. If this string is empty, an error+ -- will occur.+ -> JSString+ -- ^ Input text.+ -> [JSString]+splitOn' pat src+ | null pat = emptyError "splitOn'"+ | otherwise = unsafeCoerce (js_splitOn pat src)+{-# NOINLINE splitOn' #-}+--- {-# INLINE [1] splitOn' #-}++-- | /O(n)/ Splits a 'JSString' into components delimited by separators,+-- where the predicate returns True for a separator element. The+-- resulting components do not contain the separators. Two adjacent+-- separators result in an empty component in the output. eg.+--+-- >>> split (=='a') "aabbaca"+-- ["","","bb","c",""]+--+-- >>> split (=='a') ""+-- [""]+split :: (Char -> Bool) -> JSString -> [JSString]+split p x = case js_length x of+ 0# -> [empty]+ l -> loop 0# 0# l+ where+ loop s i l+ | isTrue# (i >=# l) = [js_substr s i x]+ | otherwise =+ let ch = js_uncheckedIndex i x+ i' = i +# charWidth ch+ in if p (C# (chr# ch))+ then js_substr s (i -# s) x : loop i' i' l+ else loop s i' l+{-# INLINE split #-}++-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last+-- element may be shorter than the other chunks, depending on the+-- length of the input. Examples:+--+-- >>> chunksOf 3 "foobarbaz"+-- ["foo","bar","baz"]+--+-- >>> chunksOf 4 "haskell.org"+-- ["hask","ell.","org"]+chunksOf :: Int -> JSString -> [JSString]+chunksOf (I# k) p = go 0#+ where+ go i = case js_chunksOf1 k i p of+ (# n, c #) -> case n of+ -1# -> []+ _ -> c : go n+{-# INLINE chunksOf #-}++-- | /O(n)/ Splits a 'JSString' into components of length @k@. The last+-- element may be shorter than the other chunks, depending on the+-- length of the input. Examples:+--+-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]+-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]+chunksOf' :: Int -> JSString -> [JSString]+chunksOf' (I# k) p = unsafeCoerce (js_chunksOf k p)+{-# INLINE chunksOf' #-}++-- ----------------------------------------------------------------------------+-- * Searching++-------------------------------------------------------------------------------+-- ** Searching with a predicate++-- | /O(n)/ The 'find' function takes a predicate and a 'JSString', and+-- returns the first element matching the predicate, or 'Nothing' if+-- there is no such element.+find :: (Char -> Bool) -> JSString -> Maybe Char+find p t = S.findBy p (stream t)+{-# INLINE find #-}++-- | /O(n)/ The 'partition' function takes a predicate and a 'JSString',+-- and returns the pair of 'JSString's with elements which do and do not+-- satisfy the predicate, respectively; i.e.+--+-- > partition p t == (filter p t, filter (not . p) t)+partition :: (Char -> Bool) -> JSString -> (JSString, JSString)+partition p t = (filter p t, filter (not . p) t)+{-# INLINE partition #-}++-- | /O(n)/ 'filter', applied to a predicate and a 'JSString',+-- returns a 'JSString' containing those characters that satisfy the+-- predicate.+filter :: (Char -> Bool) -> JSString -> JSString+filter p t = unstream (S.filter p (stream t))+{-# INLINE filter #-}++-- | /O(n+m)/ Find the first instance of @needle@ (which must be+-- non-'null') in @haystack@. The first element of the returned tuple+-- is the prefix of @haystack@ before @needle@ is matched. The second+-- is the remainder of @haystack@, starting with the match.+--+-- Examples:+--+-- >>> breakOn "::" "a::b::c"+-- ("a","::b::c")+--+-- >>> breakOn "/" "foobar"+-- ("foobar","")+--+-- Laws:+--+-- > append prefix match == haystack+-- > where (prefix, match) = breakOn needle haystack+--+-- If you need to break a string by a substring repeatedly (e.g. you+-- want to break on every instance of a substring), use 'breakOnAll'+-- instead, as it has lower startup overhead.+--+-- In (unlikely) bad cases, this function's time complexity degrades+-- towards /O(n*m)/.+breakOn :: JSString -> JSString -> (JSString, JSString)+breakOn pat src+ | null pat = emptyError "breakOn"+ | otherwise = case js_breakOn pat src of (# y, z #) -> (y, z)+{-# INLINE breakOn #-}++-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the+-- string.+--+-- The first element of the returned tuple is the prefix of @haystack@+-- up to and including the last match of @needle@. The second is the+-- remainder of @haystack@, following the match.+--+-- >>> breakOnEnd "::" "a::b::c"+-- ("a::b::","c")+breakOnEnd :: JSString -> JSString -> (JSString, JSString)+breakOnEnd pat src+ | null pat = emptyError "breakOnEnd"+ | otherwise = case js_breakOnEnd pat src of (# y, z #) -> (y, z)+{-# INLINE breakOnEnd #-}++-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in+-- @haystack@. Each element of the returned list consists of a pair:+--+-- * The entire string prior to the /k/th match (i.e. the prefix)+--+-- * The /k/th match, followed by the remainder of the string+--+-- Examples:+--+-- >>> breakOnAll "::" ""+-- []+--+-- >>> breakOnAll "/" "a/b/c/"+-- [("a","/b/c/"),("a/b","/c/"),("a/b/c","/")]+--+-- In (unlikely) bad cases, this function's time complexity degrades+-- towards /O(n*m)/.+--+-- The @needle@ parameter may not be empty.+breakOnAll :: JSString -- ^ @needle@ to search for+ -> JSString -- ^ @haystack@ in which to search+ -> [(JSString, JSString)]+breakOnAll pat src+ | null pat = emptyError "breakOnAll"+ | otherwise = go 0#+ where+ go i = case js_breakOnAll1 i pat src of+ (# n, x, y #) -> case n of+ -1# -> []+ _ -> (x,y) : go n+{-# INLINE breakOnAll #-}++breakOnAll' :: JSString -- ^ @needle@ to search for+ -> JSString -- ^ @haystack@ in which to search+ -> [(JSString, JSString)]+breakOnAll' pat src+ | null pat = emptyError "breakOnAll'"+ | otherwise = unsafeCoerce (js_breakOnAll pat src)+{-# INLINE breakOnAll' #-}++-------------------------------------------------------------------------------+-- ** Indexing 'JSString's++-- $index+--+-- If you think of a 'JSString' value as an array of 'Char' values (which+-- it is not), you run the risk of writing inefficient code.+--+-- An idiom that is common in some languages is to find the numeric+-- offset of a character or substring, then use that number to split+-- or trim the searched string. With a 'JSString' value, this approach+-- would require two /O(n)/ operations: one to perform the search, and+-- one to operate from wherever the search ended.+--+-- For example, suppose you have a string that you want to split on+-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of+-- searching for the index of @\"::\"@ and taking the substrings+-- before and after that index, you would instead use @breakOnAll \"::\"@.++-- | /O(n)/ 'JSString' index (subscript) operator, starting from 0.+index :: JSString -> Int -> Char+index t n = S.index (stream t) n+{-# INLINE index #-}++-- | /O(n)/ The 'findIndex' function takes a predicate and a 'JSString'+-- and returns the index of the first element in the 'JSString' satisfying+-- the predicate. Subject to fusion.+findIndex :: (Char -> Bool) -> JSString -> Maybe Int+findIndex p t = S.findIndex p (stream t)+{-# INLINE findIndex #-}++-- | /O(n+m)/ The 'count' function returns the number of times the+-- query string appears in the given 'JSString'. An empty query string is+-- invalid, and will cause an error to be raised.+--+-- In (unlikely) bad cases, this function's time complexity degrades+-- towards /O(n*m)/.+count :: JSString -> JSString -> Int+count pat src+ | null pat = emptyError "count"+ | otherwise = I# (js_count pat src)+{-# INLINE [1] count #-}++-- RULES+-- "JSSTRING count/singleton -> countChar" [~1] forall c t.+-- count (singleton c) t = countChar c t+--++-- | /O(n)/ The 'countChar' function returns the number of times the+-- query element appears in the given 'JSString'. Subject to fusion.+countChar :: Char -> JSString -> Int+countChar c t = S.countChar c (stream t)+{-# INLINE countChar #-}++-------------------------------------------------------------------------------+-- * Zipping++-- | /O(n)/ 'zip' takes two 'JSString's and returns a list of+-- corresponding pairs of bytes. If one input 'JSString' is short,+-- excess elements of the longer 'JSString' are discarded. This is+-- equivalent to a pair of 'unpack' operations.+zip :: JSString -> JSString -> [(Char,Char)]+zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)+{-# INLINE zip #-}++-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function+-- given as the first argument, instead of a tupling function.+-- Performs replacement on invalid scalar values.+zipWith :: (Char -> Char -> Char) -> JSString -> JSString -> JSString+zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))+ where g a b = safe (f a b)+{-# INLINE zipWith #-}++-- | /O(n)/ Breaks a 'JSString' up into a list of words, delimited by 'Char's+-- representing white space.+words :: JSString -> [JSString]+words x = loop 0# -- js_words x {- t@(Text arr off len) = loop 0 0+ where+ loop i = case js_words1 i x of+ (# n, w #) -> case n of+ -1# -> []+ _ -> w : loop n+{-# INLINE words #-}++-- fixme: strict words' that allocates the whole list in one go+words' :: JSString -> [JSString]+words' x = unsafeCoerce (js_words x)+{-# INLINE words' #-}++-- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at+-- newline 'Char's. The resulting strings do not contain newlines.+lines :: JSString -> [JSString]+lines ps = loop 0#+ where+ loop i = case js_lines1 i ps of+ (# n, l #) -> case n of+ -1# -> []+ _ -> l : loop n+{-# INLINE lines #-}++lines' :: JSString -> [JSString]+lines' ps = unsafeCoerce (js_lines ps)+{-# INLINE lines' #-}++{-+-- | /O(n)/ Portably breaks a 'JSString' up into a list of 'JSString's at line+-- boundaries.+--+-- A line boundary is considered to be either a line feed, a carriage+-- return immediately followed by a line feed, or a carriage return.+-- This accounts for both Unix and Windows line ending conventions,+-- and for the old convention used on Mac OS 9 and earlier.+lines' :: Text -> [Text]+lines' ps | null ps = []+ | otherwise = h : case uncons t of+ Nothing -> []+ Just (c,t')+ | c == '\n' -> lines t'+ | c == '\r' -> case uncons t' of+ Just ('\n',t'') -> lines t''+ _ -> lines t'+ where (h,t) = span notEOL ps+ notEOL c = c /= '\n' && c /= '\r'++-}++-- | /O(n)/ Joins lines, after appending a terminating newline to+-- each.+unlines :: [JSString] -> JSString+unlines xs = rnf xs `seq` js_unlines (unsafeCoerce xs)+{-# INLINE unlines #-}++-- | /O(n)/ Joins words using single space characters.+unwords :: [JSString] -> JSString+unwords xs = rnf xs `seq` js_unwords (unsafeCoerce xs)+{-# INLINE unwords #-}++-- | /O(n)/ The 'isPrefixOf' function takes two 'JSString's and returns+-- 'True' iff the first is a prefix of the second. Subject to fusion.+isPrefixOf :: JSString -> JSString -> Bool+isPrefixOf x y = js_isPrefixOf x y+{-# INLINE [1] isPrefixOf #-}++{-# RULES+"JSSTRING isPrefixOf -> fused" [~1] forall x y.+ isPrefixOf x y = S.isPrefixOf (stream x) (stream y)+"JSSTRING isPrefixOf -> unfused" [1] forall x y.+ S.isPrefixOf (stream x) (stream y) = isPrefixOf x y+ #-}++-- | /O(n)/ The 'isSuffixOf' function takes two 'JSString's and returns+-- 'True' iff the first is a suffix of the second.+isSuffixOf :: JSString -> JSString -> Bool+isSuffixOf x y = js_isSuffixOf x y+{-# INLINE isSuffixOf #-}++-- | The 'isInfixOf' function takes two 'JSString's and returns+-- 'True' iff the first is contained, wholly and intact, anywhere+-- within the second.+--+-- Complexity depends on how the JavaScript engine implements+-- String.prototype.find.+isInfixOf :: JSString -> JSString -> Bool+isInfixOf needle haystack = js_isInfixOf needle haystack+{-# INLINE [1] isInfixOf #-}++{-# RULES+"JSSTRING isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h.+ isInfixOf (singleton n) h = S.elem n (S.stream h)+ #-}++-------------------------------------------------------------------------------+-- * View patterns++-- | /O(n)/ Return the suffix of the second string if its prefix+-- matches the entire first string.+--+-- Examples:+--+-- >>> stripPrefix "foo" "foobar"+-- Just "bar"+--+-- >>> stripPrefix "" "baz"+-- Just "baz"+--+-- >>> stripPrefix "foo" "quux"+-- Nothing+--+-- This is particularly useful with the @ViewPatterns@ extension to+-- GHC, as follows:+--+-- > {-# LANGUAGE ViewPatterns #-}+-- > import Data.Text as T+-- >+-- > fnordLength :: JSString -> Int+-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf+-- > fnordLength _ = -1+stripPrefix :: JSString -> JSString -> Maybe JSString+stripPrefix x y = unsafeCoerce (js_stripPrefix x y)+{-# INLINE stripPrefix #-}++-- | /O(n)/ Find the longest non-empty common prefix of two strings+-- and return it, along with the suffixes of each string at which they+-- no longer match.+--+-- If the strings do not have a common prefix or either one is empty,+-- this function returns 'Nothing'.+--+-- Examples:+--+-- >>> commonPrefixes "foobar" "fooquux"+-- Just ("foo","bar","quux")+--+-- >>> commonPrefixes "veeble" "fetzer"+-- Nothing+--+-- >>> commonPrefixes "" "baz"+-- Nothing+commonPrefixes :: JSString -> JSString -> Maybe (JSString,JSString,JSString)+commonPrefixes x y = unsafeCoerce (js_commonPrefixes x y)+{-# INLINE commonPrefixes #-}++-- | /O(n)/ Return the prefix of the second string if its suffix+-- matches the entire first string.+--+-- Examples:+--+-- >>> stripSuffix "bar" "foobar"+-- Just "foo"+--+-- >>> stripSuffix "" "baz"+-- Just "baz"+--+-- >>> stripSuffix "foo" "quux"+-- Nothing+--+-- This is particularly useful with the @ViewPatterns@ extension to+-- GHC, as follows:+--+-- > {-# LANGUAGE ViewPatterns #-}+-- > import Data.Text as T+-- >+-- > quuxLength :: Text -> Int+-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre+-- > quuxLength _ = -1+stripSuffix :: JSString -> JSString -> Maybe JSString+stripSuffix x y = unsafeCoerce (js_stripSuffix x y)+{-# INLINE stripSuffix #-}++-- | Add a list of non-negative numbers. Errors out on overflow.+sumP :: String -> [Int] -> Int+sumP fun = go 0+ where go !a (x:xs)+ | ax >= 0 = go ax xs+ | otherwise = overflowError fun+ where ax = a + x+ go a _ = a++emptyError :: String -> a+emptyError fun = P.error $ "Data.JSString." ++ fun ++ ": empty input"++overflowError :: String -> a+overflowError fun = P.error $ "Data.JSString." ++ fun ++ ": size overflow"++charWidth :: Int# -> Int#+charWidth cp | isTrue# (cp >=# 0x10000#) = 2#+ | otherwise = 1#+{-# INLINE charWidth #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "h$jsstringPack($1)" js_pack :: Exts.Any -> JSString+foreign import javascript unsafe+ "$1===''" js_null :: JSString -> Bool+foreign import javascript unsafe+ "$1===null" js_isNull :: JSVal -> Bool+foreign import javascript unsafe+ "$1===$2" js_eq :: JSString -> JSString -> Bool+foreign import javascript unsafe+-- "h$jsstringAppend" js_append :: JSString -> JSString -> JSString -- debug+ "$1+$2" js_append :: JSString -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringCompare" js_compare :: JSString -> JSString -> Int#+-- "($1<$2)?-1:(($1>$2)?1:0)" js_compare :: JSString -> JSString -> Int#+foreign import javascript unsafe+ "h$jsstringSingleton" js_singleton :: Char -> JSString+foreign import javascript unsafe+ "h$jsstringUnpack" js_unpack :: JSString -> Exts.Any -- String+foreign import javascript unsafe+ "h$jsstringCons" js_cons :: Char -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringSnoc" js_snoc :: JSString -> Char -> JSString+foreign import javascript unsafe+ "h$jsstringUncons" js_uncons :: JSString -> (# Int#, JSString #)+foreign import javascript unsafe+ "h$jsstringUnsnoc" js_unsnoc :: JSString -> (# Int#, JSString #)+foreign import javascript unsafe+ "$3.substr($1,$2)" js_substr :: Int# -> Int# -> JSString -> JSString+foreign import javascript unsafe+ "$2.substr($1)" js_substr1 :: Int# -> JSString -> JSString+foreign import javascript unsafe+ "$3.substring($1,$2)" js_substring :: Int# -> Int# -> JSString -> JSString+foreign import javascript unsafe+ "$1.length" js_length :: JSString -> Int#+foreign import javascript unsafe+ "(($2.charCodeAt($1)|1023)===0xDBFF)?2:1" js_charWidthAt+ :: Int# -> JSString -> Int#+foreign import javascript unsafe+ "h$jsstringIndex" js_index :: Int# -> JSString -> Int#+foreign import javascript unsafe+ "h$jsstringIndexR" js_indexR :: Int# -> JSString -> Int#+foreign import javascript unsafe+ "h$jsstringUncheckedIndex" js_uncheckedIndex :: Int# -> JSString -> Int#+foreign import javascript unsafe+ "h$jsstringIndexR" js_uncheckedIndexR :: Int# -> JSString -> Int#++-- js_head and js_last return -1 for empty string+foreign import javascript unsafe+ "h$jsstringHead" js_head :: JSString -> Int#+foreign import javascript unsafe+ "h$jsstringLast" js_last :: JSString -> Int#++foreign import javascript unsafe+ "h$jsstringInit" js_init :: JSString -> JSVal -- null for empty string+foreign import javascript unsafe+ "h$jsstringTail" js_tail :: JSString -> JSVal -- null for empty string+foreign import javascript unsafe+ "h$jsstringReverse" js_reverse :: JSString -> JSString+foreign import javascript unsafe+ "h$jsstringGroup" js_group :: JSString -> Exts.Any {- [JSString] -}+--foreign import javascript unsafe+-- "h$jsstringGroup1" js_group1+-- :: Int# -> Bool -> JSString -> (# Int#, JSString #)+foreign import javascript unsafe+ "h$jsstringConcat" js_concat :: Exts.Any {- [JSString] -} -> JSString+-- debug this below!+foreign import javascript unsafe+ "h$jsstringReplace" js_replace :: JSString -> JSString -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringCount" js_count :: JSString -> JSString -> Int#+foreign import javascript unsafe+ "h$jsstringWords1" js_words1 :: Int# -> JSString -> (# Int#, JSString #)+foreign import javascript unsafe+ "h$jsstringWords" js_words :: JSString -> Exts.Any -- [JSString]+foreign import javascript unsafe+ "h$jsstringLines1" js_lines1 :: Int# -> JSString -> (# Int#, JSString #)+foreign import javascript unsafe+ "h$jsstringLines" js_lines :: JSString -> Exts.Any -- [JSString]+foreign import javascript unsafe+ "h$jsstringUnlines" js_unlines :: Exts.Any {- [JSString] -} -> JSString+foreign import javascript unsafe+ "h$jsstringUnwords" js_unwords :: Exts.Any {- [JSString] -} -> JSString+foreign import javascript unsafe+ "h$jsstringIsPrefixOf" js_isPrefixOf :: JSString -> JSString -> Bool+foreign import javascript unsafe+ "h$jsstringIsSuffixOf" js_isSuffixOf :: JSString -> JSString -> Bool+foreign import javascript unsafe+ "h$jsstringIsInfixOf" js_isInfixOf :: JSString -> JSString -> Bool+foreign import javascript unsafe+ "h$jsstringStripPrefix" js_stripPrefix+ :: JSString -> JSString -> Exts.Any -- Maybe JSString+foreign import javascript unsafe+ "h$jsstringStripSuffix" js_stripSuffix+ :: JSString -> JSString -> Exts.Any -- Maybe JSString+foreign import javascript unsafe+ "h$jsstringCommonPrefixes" js_commonPrefixes+ :: JSString -> JSString -> Exts.Any -- Maybe (JSString, JSString, JSString)+foreign import javascript unsafe+ "h$jsstringChunksOf" js_chunksOf+ :: Int# -> JSString -> Exts.Any -- [JSString]+foreign import javascript unsafe+ "h$jsstringChunksOf1" js_chunksOf1+ :: Int# -> Int# -> JSString -> (# Int#, JSString #)+foreign import javascript unsafe+ "h$jsstringSplitAt" js_splitAt+ :: Int# -> JSString -> (# JSString, JSString #)+foreign import javascript unsafe+ "h$jsstringSplitOn" js_splitOn+ :: JSString -> JSString -> Exts.Any -- [JSString]+foreign import javascript unsafe+ "h$jsstringSplitOn1" js_splitOn1+ :: Int# -> JSString -> JSString -> (# Int#, JSString #)+foreign import javascript unsafe+ "h$jsstringBreakOn" js_breakOn+ :: JSString -> JSString -> (# JSString, JSString #)+foreign import javascript unsafe+ "h$jsstringBreakOnEnd" js_breakOnEnd+ :: JSString -> JSString -> (# JSString, JSString #)+foreign import javascript unsafe+ "h$jsstringBreakOnAll" js_breakOnAll+ :: JSString -> JSString -> Exts.Any -- [(JSString, JSString)]+foreign import javascript unsafe+ "h$jsstringBreakOnAll1" js_breakOnAll1+ :: Int# -> JSString -> JSString -> (# Int#, JSString, JSString #)+foreign import javascript unsafe+ "h$jsstringDrop" js_drop :: Int# -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringDropEnd" js_dropEnd :: Int -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringTake" js_take :: Int# -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringTakeEnd" js_takeEnd :: Int# -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringReplicate" js_replicate :: Int# -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringReplicateChar" js_replicateChar :: Int -> Char -> JSString+foreign import javascript unsafe+ "var l=$1.length; $r=l==1||(l==2&&($1.charCodeAt(0)|1023)==0xDFFF);"+ js_isSingleton :: JSString -> Bool+foreign import javascript unsafe+ "h$jsstringIntersperse"+ js_intersperse :: Char -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringIntercalate"+ js_intercalate :: JSString -> Exts.Any {- [JSString] -} -> JSString+foreign import javascript unsafe+ "$1.toUpperCase()" js_toUpper :: JSString -> JSString+foreign import javascript unsafe+ "$1.toLowerCase()" js_toLower :: JSString -> JSString
+ Data/JSString/Int.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GHCForeignImportPrim #-}++module Data.JSString.Int+ ( decimal+ , hexadecimal+ ) where++import Data.JSString++import Data.Monoid++import GHC.Int+import GHC.Word+import GHC.Exts ( ByteArray#+ , Int(..), Int#, Int64#+ , Word(..), Word#, Word64#+ , (<#), (<=#), isTrue# )++import GHC.Integer.GMP.Internals+import Unsafe.Coerce+import GHCJS.Prim++decimal :: Integral a => a -> JSString+decimal i = decimal' i+{-# RULES "decimal/Int" decimal = decimalI :: Int -> JSString #-}+{-# RULES "decimal/Int8" decimal = decimalI8 :: Int8 -> JSString #-}+{-# RULES "decimal/Int16" decimal = decimalI16 :: Int16 -> JSString #-}+{-# RULES "decimal/Int32" decimal = decimalI32 :: Int32 -> JSString #-}+{-# RULES "decimal/Int64" decimal = decimalI64 :: Int64 -> JSString #-}+{-# RULES "decimal/Word" decimal = decimalW :: Word -> JSString #-}+{-# RULES "decimal/Word8" decimal = decimalW8 :: Word8 -> JSString #-}+{-# RULES "decimal/Word16" decimal = decimalW16 :: Word16 -> JSString #-}+{-# RULES "decimal/Word32" decimal = decimalW32 :: Word32 -> JSString #-}+{-# RULES "decimal/Word64" decimal = decimalW64 :: Word64 -> JSString #-}+{-# RULES "decimal/Integer" decimal = decimalInteger :: Integer -> JSString #-}+{-# SPECIALIZE decimal :: Integer -> JSString #-}+{-# SPECIALIZE decimal :: Int -> JSString #-}+{-# SPECIALIZE decimal :: Int8 -> JSString #-}+{-# SPECIALIZE decimal :: Int16 -> JSString #-}+{-# SPECIALIZE decimal :: Int32 -> JSString #-}+{-# SPECIALIZE decimal :: Int64 -> JSString #-}+{-# SPECIALIZE decimal :: Word -> JSString #-}+{-# SPECIALIZE decimal :: Word8 -> JSString #-}+{-# SPECIALIZE decimal :: Word16 -> JSString #-}+{-# SPECIALIZE decimal :: Word32 -> JSString #-}+{-# SPECIALIZE decimal :: Word64 -> JSString #-}+{-# INLINE [1] decimal #-}++decimalI :: Int -> JSString+decimalI (I# x) = js_decI x+{-# INLINE decimalI #-}++decimalI8 :: Int8 -> JSString+decimalI8 (I8# x) = js_decI x+{-# INLINE decimalI8 #-}++decimalI16 :: Int16 -> JSString+decimalI16 (I16# x) = js_decI x+{-# INLINE decimalI16 #-}++decimalI32 :: Int32 -> JSString+decimalI32 (I32# x) = js_decI x+{-# INLINE decimalI32 #-}++decimalI64 :: Int64 -> JSString+decimalI64 (I64# x) = js_decI64 x+{-# INLINE decimalI64 #-}++decimalW8 :: Word8 -> JSString+decimalW8 (W8# x) = js_decW x+{-# INLINE decimalW8 #-}++decimalW16 :: Word16 -> JSString+decimalW16 (W16# x) = js_decW x+{-# INLINE decimalW16 #-}++decimalW32 :: Word32 -> JSString+decimalW32 (W32# x) = js_decW32 x+{-# INLINE decimalW32 #-}++decimalW64 :: Word64 -> JSString+decimalW64 (W64# x) = js_decW64 x+{-# INLINE decimalW64 #-}++decimalW :: Word -> JSString+decimalW (W# x) = js_decW32 x+{-# INLINE decimalW #-}++-- hack warning, we should really expose J# somehow+data MyI = MyS Int# | MyJ Int# ByteArray#++decimalInteger :: Integer -> JSString+decimalInteger !i = js_decInteger (unsafeCoerce i)+{-# INLINE decimalInteger #-}++decimal' :: Integral a => a -> JSString+decimal' i = decimalInteger (toInteger i)+{-# NOINLINE decimal' #-}+{-+ | i < 0 = if i <= -10+ then let (q, r) = i `quotRem` (-10)+ !(I# rr) = fromIntegral r+ in js_minusDigit (positive q) rr+ else js_minus (positive (negate i))+ | otherwise = positive i++positive :: (Integral a) => a -> JSString+positive i+ | toInteger i < 1000000000 = let !(I# x) = fromIntegral i in js_decI x+ | otherwise = let (q, r) = i `quotRem` 1000000000+ !(I# x) = fromIntegral r+ in positive q <> js_decIPadded9 x+-}++hexadecimal :: Integral a => a -> JSString+hexadecimal i = hexadecimal' i+{-# RULES "hexadecimal/Int" hexadecimal = hexI :: Int -> JSString #-}+{-# RULES "hexadecimal/Int8" hexadecimal = hexI8 :: Int8 -> JSString #-}+{-# RULES "hexadecimal/Int16" hexadecimal = hexI16 :: Int16 -> JSString #-}+{-# RULES "hexadecimal/Int32" hexadecimal = hexI32 :: Int32 -> JSString #-}+{-# RULES "hexadecimal/Int64" hexadecimal = hexI64 :: Int64 -> JSString #-}+{-# RULES "hexadecimal/Word" hexadecimal = hexW :: Word -> JSString #-}+{-# RULES "hexadecimal/Word8" hexadecimal = hexW8 :: Word8 -> JSString #-}+{-# RULES "hexadecimal/Word16" hexadecimal = hexW16 :: Word16 -> JSString #-}+{-# RULES "hexadecimal/Word32" hexadecimal = hexW32 :: Word32 -> JSString #-}+{-# RULES "hexadecimal/Word64" hexadecimal = hexW64 :: Word64 -> JSString #-}+{-# RULES "hexadecimal/Integer" hexadecimal = hexInteger :: Integer -> JSString #-}+{-# SPECIALIZE hexadecimal :: Integer -> JSString #-}+{-# SPECIALIZE hexadecimal :: Int -> JSString #-}+{-# SPECIALIZE hexadecimal :: Int8 -> JSString #-}+{-# SPECIALIZE hexadecimal :: Int16 -> JSString #-}+{-# SPECIALIZE hexadecimal :: Int32 -> JSString #-}+{-# SPECIALIZE hexadecimal :: Int64 -> JSString #-}+{-# SPECIALIZE hexadecimal :: Word -> JSString #-}+{-# SPECIALIZE hexadecimal :: Word8 -> JSString #-}+{-# SPECIALIZE hexadecimal :: Word16 -> JSString #-}+{-# SPECIALIZE hexadecimal :: Word32 -> JSString #-}+{-# SPECIALIZE hexadecimal :: Word64 -> JSString #-}+{-# INLINE [1] hexadecimal #-}++hexadecimal' :: Integral a => a -> JSString+hexadecimal' i+ | i < 0 = error hexErrMsg+ | otherwise = hexInteger (toInteger i)+{-# NOINLINE hexadecimal' #-}++hexInteger :: Integer -> JSString+hexInteger !i+ | i < 0 = error hexErrMsg+ | otherwise = js_hexInteger (unsafeCoerce i)+{-# INLINE hexInteger #-}++hexI :: Int -> JSString+hexI (I# x) = if isTrue# (x <# 0#)+ then error hexErrMsg+ else js_hexI x+{-# INLINE hexI #-}++hexI8 :: Int8 -> JSString+hexI8 (I8# x) =+ if isTrue# (x <# 0#)+ then error hexErrMsg+ else js_hexI x+{-# INLINE hexI8 #-}++hexI16 :: Int16 -> JSString+hexI16 (I16# x) =+ if isTrue# (x <# 0#)+ then error hexErrMsg+ else js_hexI x+{-# INLINE hexI16 #-}++hexI32 :: Int32 -> JSString+hexI32 (I32# x) =+ if isTrue# (x <# 0#)+ then error hexErrMsg+ else js_hexI x+{-# INLINE hexI32 #-}++hexI64 :: Int64 -> JSString+hexI64 i@(I64# x) =+ if i < 0+ then error hexErrMsg+ else js_hexI64 x+{-# INLINE hexI64 #-}++hexW :: Word -> JSString+hexW (W# x) = js_hexW32 x+{-# INLINE hexW #-}++hexW8 :: Word8 -> JSString+hexW8 (W8# x) = js_hexW x+{-# INLINE hexW8 #-}++hexW16 :: Word16 -> JSString+hexW16 (W16# x) = js_hexW x+{-# INLINE hexW16 #-}++hexW32 :: Word32 -> JSString+hexW32 (W32# x) = js_hexW32 x+{-# INLINE hexW32 #-}++hexW64 :: Word64 -> JSString+hexW64 (W64# x) = js_hexW64 x+{-# INLINE hexW64 #-}++hexErrMsg :: String+hexErrMsg = "Data.JSString.Int.hexadecimal: applied to negative number"++-- ----------------------------------------------------------------------------++foreign import javascript unsafe+ "''+$1"+ js_decI :: Int# -> JSString+foreign import javascript unsafe+ "h$jsstringDecI64"+ js_decI64 :: Int64# -> JSString+foreign import javascript unsafe+ "''+$1"+ js_decW :: Word# -> JSString+foreign import javascript unsafe+ "''+(($1>=0)?$1:($1+4294967296))"+ js_decW32 :: Word# -> JSString+foreign import javascript unsafe+ "h$jsstringDecW64($1_1, $1_2)"+ js_decW64 :: Word64# -> JSString+foreign import javascript unsafe+ "h$jsstringDecInteger($1)"+ js_decInteger :: Any -> JSString++-- these are expected to be only applied to nonnegative integers+foreign import javascript unsafe+ "$1.toString(16)"+ js_hexI :: Int# -> JSString+foreign import javascript unsafe+ "h$jsstringHexI64"+ js_hexI64 :: Int64# -> JSString++foreign import javascript unsafe+ "$1.toString(16)"+ js_hexW :: Word# -> JSString+foreign import javascript unsafe+ "(($1>=0)?$1:($1+4294967296)).toString(16)"+ js_hexW32 :: Word# -> JSString+foreign import javascript unsafe+ "h$jsstringHexW64($1_1, $1_2)"+ js_hexW64 :: Word64# -> JSString+foreign import javascript unsafe+ "h$jsstringHexInteger($1)"+ js_hexInteger :: Any -> JSString++foreign import javascript unsafe+ "'-'+$1+(-$2)"+ js_minusDigit :: JSString -> Int# -> JSString+foreign import javascript unsafe+ "'-'+$1"+ js_minus :: JSString -> JSString++--+foreign import javascript unsafe+ "h$jsstringDecIPadded9"+ js_decIPadded9 :: Int# -> JSString+foreign import javascript unsafe+ "h$jsstringHexIPadded8"+ js_hexIPadded8 :: Int# -> JSString
+ Data/JSString/Internal.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE MagicHash, NegativeLiterals, BangPatterns,+ ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes+ #-}++module Data.JSString.Internal where+{-+import Prelude ( Eq(..), Ord(..), Show(..), Read(..), Bool(..)+ , seq, Ordering(..))+import Data.Data (Data(..))+import Data.Monoid (Monoid(..))+import Control.DeepSeq (NFData(..))+import qualified GHC.Exts as Exts++import Unsafe.Coerce+import GHCJS.Prim (JSVal)++newtype JSString = JSString (JSVal ())++instance Monoid JSString where+ mempty = empty+ mappend = append+ mconcat = concat++instance Eq JSString where+ (==) = eqJSString++instance Ord JSString where+ compare = compareJSString++instance NFData JSString where rnf !_ = ()++compareJSString :: JSString -> JSString -> Ordering+compareJSString x y = Exts.tagToEnum# (js_compare x y Exts.+# 2#)+{-# INLINE compareJSString #-}++eqJSString :: JSString -> JSString -> Bool+eqJSString x y = js_eq+{-# INLINE eqJSString #-}++-- | /O(n)/ Appends one 'JSString' to the other by copying both of them+-- into a new 'JSString'. Subject to fusion.+append :: JSString -> JSString -> JSString+append x y = js_append x y+{-# INLINE append #-}++{-# RULES+"JSSTRING append -> fused" [~1] forall t1 t2.+ append t1 t2 = unstream (S.append (stream t1) (stream t2))+"JSSTRING append -> unfused" [1] forall t1 t2.+ unstream (S.append (stream t1) (stream t2)) = append t1 t2+ #-}++-- | /O(n)/ Concatenate a list of 'JSString's.+concat :: [JSString] -> JSString+concat ts = rnf ts `seq` js_concat (unsafeCoerce ts)+{-# INLINE concat #-}++empty :: JSString+empty = js_empty+{-# INLINE empty #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$r='';" js_empty :: JSString+foreign import javascript unsafe+ "$1+$2" js_append :: JSString -> JSString -> JSString+foreign import javascript unsafe+ "$1===$2" js_eq :: JSString -> JSString -> Bool+foreign import javascript unsafe+ "$1.localeCompare($2)" js_compare :: JSString -> JSString -> Exts.Int#+foreign import javascript unsafe+ "h$jsstringConcat" js_concat :: Exts.Any -> JSString+-}
+ Data/JSString/Internal/Fusion.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE BangPatterns, MagicHash, ForeignFunctionInterface, JavaScriptFFI,+ UnliftedFFITypes+ #-}+module Data.JSString.Internal.Fusion ( -- * Types+ Stream(..)+ , Step(..)++ -- * Creation and elimination+ , stream+ , unstream+ , reverseStream++ , length++ -- * Transformations+ , reverse+ + -- * Construction+ -- ** Scans+ , reverseScanr++ -- ** Accumulating maps+ , mapAccumL++ -- ** Generation and unfolding+ , unfoldrN++ -- * Indexing+ , index+ , findIndex+ , countChar+ ) where++import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#))++import Prelude hiding (length, reverse)+import Data.Char++import Data.JSString.Internal.Type (JSString(..))+import qualified Data.JSString.Internal.Type as I+import Data.JSString.Internal.Fusion.Types+import qualified Data.JSString.Internal.Fusion.Common as S++import System.IO.Unsafe++import GHCJS.Prim++default (Int)++-- | /O(n)/ Convert a 'JSString' into a 'Stream Char'.+stream :: JSString -> Stream Char+stream x = + let next i = case js_index i x of+ -1# -> Done+ ch -> let !i' = i + if isTrue# (ch >=# 0x10000#)+ then 2+ else 1+ in Yield (C# (chr# ch)) i'+ in Stream next 0+{-# INLINE [0] stream #-}++-- | /O(n)/ Convert a 'JSString' into a 'Stream Char', but iterate+-- backwards.+reverseStream :: JSString -> Stream Char+reverseStream x =+ let l = js_length x+ {-# INLINE next #-}+ next i = case js_indexR i x of+ -1# -> Done+ ch -> let !i' = i - if isTrue# (ch >=# 0x10000#)+ then 2+ else 1+ in Yield (C# (chr# ch)) i'+ in Stream next (I# (l -# 1#))+{-# INLINE [0] reverseStream #-}++-- | /O(n)/ Convert a 'Stream Char' into a 'JSString'.+unstream :: Stream Char -> JSString+unstream (Stream next s) = runJSString $ \done ->+ let go !s0 = case next s0 of+ Done -> done I.empty+ Skip s1 -> go s1+ Yield x s1 -> js_newSingletonArray x >>= loop 1 s1+ loop !i !s0 a = case next s0 of+ Done -> js_packString a >>= done+ Skip s1 -> loop i s1 a+ Yield x s1 -> js_writeArray x i a >> loop (i+1) s1 a+ in go s+{-# INLINE [0] unstream #-}+{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}+++-- ----------------------------------------------------------------------------+-- * Basic stream functions++runJSString :: ((a -> IO a) -> IO a) -> a+runJSString f = unsafePerformIO (f pure)++length :: Stream Char -> Int+length = S.lengthI+{-# INLINE[0] length #-}++-- | /O(n)/ Reverse the characters of a string.+reverse :: Stream Char -> JSString+reverse (Stream next s) = runJSString $ \done ->+ let go !s0 = case next s0 of+ Done -> done I.empty+ Skip s1 -> go s1+ Yield x s1 -> js_newSingletonArray x >>= loop 1 s1+ loop !i !s0 a = case next s0 of+ Done -> js_packReverse a >>= done+ Skip s1 -> loop i s1 a+ Yield x s1 -> js_writeArray x i a >> loop (i+1) s1 a+ in go s+{-# INLINE [0] reverse #-}++-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with+-- the input and result reversed.+reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char+reverseScanr f z0 (Stream next0 s0) = Stream next (S1 :*: z0 :*: s0)+ where+ {-# INLINE next #-}+ next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s)+ next (S2 :*: z :*: s) = case next0 s of+ Yield x s' -> let !x' = f x z+ in Yield x' (S2 :*: x' :*: s')+ Skip s' -> Skip (S2 :*: z :*: s')+ Done -> Done+{-# INLINE reverseScanr #-}++-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed+-- value. However, the length of the result is limited by the+-- first argument to 'unfoldrN'. This function is more efficient than+-- 'unfoldr' when the length of the result is known.+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char+unfoldrN n = S.unfoldrNI n+{-# INLINE [0] unfoldrN #-}++-------------------------------------------------------------------------------+-- ** Indexing streams++-- | /O(n)/ stream index (subscript) operator, starting from 0.+index :: Stream Char -> Int -> Char+index = S.indexI+{-# INLINE [0] index #-}++-- | The 'findIndex' function takes a predicate and a stream and+-- returns the index of the first element in the stream+-- satisfying the predicate.+findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int+findIndex = S.findIndexI+{-# INLINE [0] findIndex #-}++-- | /O(n)/ The 'count' function returns the number of times the query+-- element appears in the given stream.+countChar :: Char -> Stream Char -> Int+countChar = S.countCharI+{-# INLINE [0] countChar #-}++-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a+-- function to each element of a 'Text', passing an accumulating+-- parameter from left to right, and returns a final 'JSString'.+mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, JSString)+mapAccumL f z0 (Stream next s0) = runJSString $ \done ->+ let go !s1 = case next s1 of+ Done -> done (z0, I.empty)+ Skip s2 -> go s2+ Yield ch s2 -> let (z1, ch1) = f z0 ch+ in js_newSingletonArray ch1 >>= loop 1 s2 z1+ loop !i !s1 !z1 a = case next s1 of+ Done -> js_packString a >>= \s -> done (z1, s)+ Skip s2 -> loop i s2 z1 a+ Yield ch1 s2 -> let (z2, ch2) = f z1 ch1+ in js_writeArray ch2 i a >> loop (i+1) s2 z2 a+ in go s0+{-# INLINE [0] mapAccumL #-}++-------------------------------------------------------------------------------++-- returns -1 for end of stream+foreign import javascript unsafe+ "h$jsstringIndex" js_index :: Int -> JSString -> Int#+foreign import javascript unsafe+ "h$jsstringIndexR" js_indexR :: Int -> JSString -> Int#+foreign import javascript unsafe+ "$1.length" js_length :: JSString -> Int#+foreign import javascript unsafe+ "$r = [$1];" js_newSingletonArray :: Char -> IO JSVal+foreign import javascript unsafe+ "$3[$2] = $1;" js_writeArray :: Char -> Int -> JSVal -> IO ()+foreign import javascript unsafe+ "h$jsstringPackArray" js_packString :: JSVal -> IO JSString+foreign import javascript unsafe+ "h$jsstringPackArrayReverse" js_packReverse :: JSVal -> IO JSString
+ Data/JSString/Internal/Fusion/CaseMapping.hs view
@@ -0,0 +1,570 @@+{-# LANGUAGE Rank2Types #-}+-- AUTOMATICALLY GENERATED - DO NOT EDIT+-- Generated by scripts/SpecialCasing.hs+-- CaseFolding-6.3.0.txt+-- Date: 2012-12-20, 22:14:35 GMT [MD]+-- SpecialCasing-6.3.0.txt+-- Date: 2013-05-08, 13:54:51 GMT [MD]++module Data.JSString.Internal.Fusion.CaseMapping where+import Data.Char+import Data.JSString.Internal.Fusion.Types++upperMapping :: forall s. Char -> s -> Step (CC s) Char+{-# INLINE upperMapping #-}+-- LATIN SMALL LETTER SHARP S+upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000')+-- LATIN SMALL LIGATURE FF+upperMapping '\xfb00' s = Yield '\x0046' (CC s '\x0046' '\x0000')+-- LATIN SMALL LIGATURE FI+upperMapping '\xfb01' s = Yield '\x0046' (CC s '\x0049' '\x0000')+-- LATIN SMALL LIGATURE FL+upperMapping '\xfb02' s = Yield '\x0046' (CC s '\x004c' '\x0000')+-- LATIN SMALL LIGATURE FFI+upperMapping '\xfb03' s = Yield '\x0046' (CC s '\x0046' '\x0049')+-- LATIN SMALL LIGATURE FFL+upperMapping '\xfb04' s = Yield '\x0046' (CC s '\x0046' '\x004c')+-- LATIN SMALL LIGATURE LONG S T+upperMapping '\xfb05' s = Yield '\x0053' (CC s '\x0054' '\x0000')+-- LATIN SMALL LIGATURE ST+upperMapping '\xfb06' s = Yield '\x0053' (CC s '\x0054' '\x0000')+-- ARMENIAN SMALL LIGATURE ECH YIWN+upperMapping '\x0587' s = Yield '\x0535' (CC s '\x0552' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN NOW+upperMapping '\xfb13' s = Yield '\x0544' (CC s '\x0546' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN ECH+upperMapping '\xfb14' s = Yield '\x0544' (CC s '\x0535' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN INI+upperMapping '\xfb15' s = Yield '\x0544' (CC s '\x053b' '\x0000')+-- ARMENIAN SMALL LIGATURE VEW NOW+upperMapping '\xfb16' s = Yield '\x054e' (CC s '\x0546' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN XEH+upperMapping '\xfb17' s = Yield '\x0544' (CC s '\x053d' '\x0000')+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE+upperMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS+upperMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS+upperMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')+-- LATIN SMALL LETTER J WITH CARON+upperMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')+-- LATIN SMALL LETTER H WITH LINE BELOW+upperMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')+-- LATIN SMALL LETTER T WITH DIAERESIS+upperMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')+-- LATIN SMALL LETTER W WITH RING ABOVE+upperMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')+-- LATIN SMALL LETTER Y WITH RING ABOVE+upperMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')+-- LATIN SMALL LETTER A WITH RIGHT HALF RING+upperMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PSILI+upperMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA+upperMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA+upperMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI+upperMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI+upperMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER ETA WITH PERISPOMENI+upperMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA+upperMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA+upperMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI+upperMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI+upperMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA+upperMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA+upperMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER RHO WITH PSILI+upperMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI+upperMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI+upperMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI+upperMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI+upperMapping '\x1f80' s = Yield '\x1f08' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI+upperMapping '\x1f81' s = Yield '\x1f09' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI+upperMapping '\x1f82' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI+upperMapping '\x1f83' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI+upperMapping '\x1f84' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI+upperMapping '\x1f85' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1f86' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1f87' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI+upperMapping '\x1f88' s = Yield '\x1f08' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI+upperMapping '\x1f89' s = Yield '\x1f09' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI+upperMapping '\x1f8a' s = Yield '\x1f0a' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI+upperMapping '\x1f8b' s = Yield '\x1f0b' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI+upperMapping '\x1f8c' s = Yield '\x1f0c' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI+upperMapping '\x1f8d' s = Yield '\x1f0d' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI+upperMapping '\x1f8e' s = Yield '\x1f0e' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI+upperMapping '\x1f8f' s = Yield '\x1f0f' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI+upperMapping '\x1f90' s = Yield '\x1f28' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI+upperMapping '\x1f91' s = Yield '\x1f29' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI+upperMapping '\x1f92' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI+upperMapping '\x1f93' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI+upperMapping '\x1f94' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI+upperMapping '\x1f95' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1f96' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1f97' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI+upperMapping '\x1f98' s = Yield '\x1f28' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI+upperMapping '\x1f99' s = Yield '\x1f29' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI+upperMapping '\x1f9a' s = Yield '\x1f2a' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI+upperMapping '\x1f9b' s = Yield '\x1f2b' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI+upperMapping '\x1f9c' s = Yield '\x1f2c' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI+upperMapping '\x1f9d' s = Yield '\x1f2d' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI+upperMapping '\x1f9e' s = Yield '\x1f2e' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI+upperMapping '\x1f9f' s = Yield '\x1f2f' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI+upperMapping '\x1fa0' s = Yield '\x1f68' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI+upperMapping '\x1fa1' s = Yield '\x1f69' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI+upperMapping '\x1fa2' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI+upperMapping '\x1fa3' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI+upperMapping '\x1fa4' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI+upperMapping '\x1fa5' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1fa6' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1fa7' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI+upperMapping '\x1fa8' s = Yield '\x1f68' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI+upperMapping '\x1fa9' s = Yield '\x1f69' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI+upperMapping '\x1faa' s = Yield '\x1f6a' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI+upperMapping '\x1fab' s = Yield '\x1f6b' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI+upperMapping '\x1fac' s = Yield '\x1f6c' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI+upperMapping '\x1fad' s = Yield '\x1f6d' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI+upperMapping '\x1fae' s = Yield '\x1f6e' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI+upperMapping '\x1faf' s = Yield '\x1f6f' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI+upperMapping '\x1fb3' s = Yield '\x0391' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI+upperMapping '\x1fbc' s = Yield '\x0391' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI+upperMapping '\x1fc3' s = Yield '\x0397' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI+upperMapping '\x1fcc' s = Yield '\x0397' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI+upperMapping '\x1ff3' s = Yield '\x03a9' (CC s '\x0399' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI+upperMapping '\x1ffc' s = Yield '\x03a9' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI+upperMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI+upperMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI+upperMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI+upperMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI+upperMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI+upperMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0399' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0399')+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399')+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI+upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399')+upperMapping c s = Yield (toUpper c) (CC s '\0' '\0')+lowerMapping :: forall s. Char -> s -> Step (CC s) Char+{-# INLINE lowerMapping #-}+-- LATIN CAPITAL LETTER I WITH DOT ABOVE+lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')+lowerMapping c s = Yield (toLower c) (CC s '\0' '\0')+titleMapping :: forall s. Char -> s -> Step (CC s) Char+{-# INLINE titleMapping #-}+-- LATIN SMALL LETTER SHARP S+titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000')+-- LATIN SMALL LIGATURE FF+titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000')+-- LATIN SMALL LIGATURE FI+titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000')+-- LATIN SMALL LIGATURE FL+titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000')+-- LATIN SMALL LIGATURE FFI+titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069')+-- LATIN SMALL LIGATURE FFL+titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c')+-- LATIN SMALL LIGATURE LONG S T+titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000')+-- LATIN SMALL LIGATURE ST+titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000')+-- ARMENIAN SMALL LIGATURE ECH YIWN+titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN NOW+titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN ECH+titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN INI+titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000')+-- ARMENIAN SMALL LIGATURE VEW NOW+titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN XEH+titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000')+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE+titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS+titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS+titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')+-- LATIN SMALL LETTER J WITH CARON+titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')+-- LATIN SMALL LETTER H WITH LINE BELOW+titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')+-- LATIN SMALL LETTER T WITH DIAERESIS+titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')+-- LATIN SMALL LETTER W WITH RING ABOVE+titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')+-- LATIN SMALL LETTER Y WITH RING ABOVE+titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')+-- LATIN SMALL LETTER A WITH RIGHT HALF RING+titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PSILI+titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA+titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA+titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI+titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI+titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER ETA WITH PERISPOMENI+titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA+titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA+titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI+titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI+titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA+titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA+titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER RHO WITH PSILI+titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI+titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI+titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI+titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI+titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI+titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000')+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI+titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000')+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI+titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI+titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI+titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI+titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345')+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI+titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345')+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI+titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345')+titleMapping c s = Yield (toTitle c) (CC s '\0' '\0')+foldMapping :: forall s. Char -> s -> Step (CC s) Char+{-# INLINE foldMapping #-}+-- MICRO SIGN+foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000')+-- LATIN SMALL LETTER SHARP S+foldMapping '\x00df' s = Yield '\x0073' (CC s '\x0073' '\x0000')+-- LATIN CAPITAL LETTER I WITH DOT ABOVE+foldMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE+foldMapping '\x0149' s = Yield '\x02bc' (CC s '\x006e' '\x0000')+-- LATIN SMALL LETTER LONG S+foldMapping '\x017f' s = Yield '\x0073' (CC s '\x0000' '\x0000')+-- LATIN SMALL LETTER J WITH CARON+foldMapping '\x01f0' s = Yield '\x006a' (CC s '\x030c' '\x0000')+-- COMBINING GREEK YPOGEGRAMMENI+foldMapping '\x0345' s = Yield '\x03b9' (CC s '\x0000' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS+foldMapping '\x0390' s = Yield '\x03b9' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS+foldMapping '\x03b0' s = Yield '\x03c5' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER FINAL SIGMA+foldMapping '\x03c2' s = Yield '\x03c3' (CC s '\x0000' '\x0000')+-- GREEK BETA SYMBOL+foldMapping '\x03d0' s = Yield '\x03b2' (CC s '\x0000' '\x0000')+-- GREEK THETA SYMBOL+foldMapping '\x03d1' s = Yield '\x03b8' (CC s '\x0000' '\x0000')+-- GREEK PHI SYMBOL+foldMapping '\x03d5' s = Yield '\x03c6' (CC s '\x0000' '\x0000')+-- GREEK PI SYMBOL+foldMapping '\x03d6' s = Yield '\x03c0' (CC s '\x0000' '\x0000')+-- GREEK KAPPA SYMBOL+foldMapping '\x03f0' s = Yield '\x03ba' (CC s '\x0000' '\x0000')+-- GREEK RHO SYMBOL+foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000')+-- GREEK LUNATE EPSILON SYMBOL+foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000')+-- ARMENIAN SMALL LIGATURE ECH YIWN+foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000')+-- GEORGIAN CAPITAL LETTER YN+foldMapping '\x10c7' s = Yield '\x2d27' (CC s '\x0000' '\x0000')+-- GEORGIAN CAPITAL LETTER AEN+foldMapping '\x10cd' s = Yield '\x2d2d' (CC s '\x0000' '\x0000')+-- LATIN SMALL LETTER H WITH LINE BELOW+foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000')+-- LATIN SMALL LETTER T WITH DIAERESIS+foldMapping '\x1e97' s = Yield '\x0074' (CC s '\x0308' '\x0000')+-- LATIN SMALL LETTER W WITH RING ABOVE+foldMapping '\x1e98' s = Yield '\x0077' (CC s '\x030a' '\x0000')+-- LATIN SMALL LETTER Y WITH RING ABOVE+foldMapping '\x1e99' s = Yield '\x0079' (CC s '\x030a' '\x0000')+-- LATIN SMALL LETTER A WITH RIGHT HALF RING+foldMapping '\x1e9a' s = Yield '\x0061' (CC s '\x02be' '\x0000')+-- LATIN SMALL LETTER LONG S WITH DOT ABOVE+foldMapping '\x1e9b' s = Yield '\x1e61' (CC s '\x0000' '\x0000')+-- LATIN CAPITAL LETTER SHARP S+foldMapping '\x1e9e' s = Yield '\x0073' (CC s '\x0073' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PSILI+foldMapping '\x1f50' s = Yield '\x03c5' (CC s '\x0313' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA+foldMapping '\x1f52' s = Yield '\x03c5' (CC s '\x0313' '\x0300')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA+foldMapping '\x1f54' s = Yield '\x03c5' (CC s '\x0313' '\x0301')+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI+foldMapping '\x1f56' s = Yield '\x03c5' (CC s '\x0313' '\x0342')+-- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI+foldMapping '\x1f80' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI+foldMapping '\x1f81' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI+foldMapping '\x1f82' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI+foldMapping '\x1f83' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI+foldMapping '\x1f84' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI+foldMapping '\x1f85' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1f86' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1f87' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI+foldMapping '\x1f88' s = Yield '\x1f00' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI+foldMapping '\x1f89' s = Yield '\x1f01' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI+foldMapping '\x1f8a' s = Yield '\x1f02' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI+foldMapping '\x1f8b' s = Yield '\x1f03' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI+foldMapping '\x1f8c' s = Yield '\x1f04' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI+foldMapping '\x1f8d' s = Yield '\x1f05' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI+foldMapping '\x1f8e' s = Yield '\x1f06' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI+foldMapping '\x1f8f' s = Yield '\x1f07' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI+foldMapping '\x1f90' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI+foldMapping '\x1f91' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI+foldMapping '\x1f92' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI+foldMapping '\x1f93' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI+foldMapping '\x1f94' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI+foldMapping '\x1f95' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1f96' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1f97' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI+foldMapping '\x1f98' s = Yield '\x1f20' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI+foldMapping '\x1f99' s = Yield '\x1f21' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI+foldMapping '\x1f9a' s = Yield '\x1f22' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI+foldMapping '\x1f9b' s = Yield '\x1f23' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI+foldMapping '\x1f9c' s = Yield '\x1f24' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI+foldMapping '\x1f9d' s = Yield '\x1f25' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI+foldMapping '\x1f9e' s = Yield '\x1f26' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI+foldMapping '\x1f9f' s = Yield '\x1f27' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI+foldMapping '\x1fa0' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI+foldMapping '\x1fa1' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI+foldMapping '\x1fa2' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI+foldMapping '\x1fa3' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI+foldMapping '\x1fa4' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI+foldMapping '\x1fa5' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1fa6' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1fa7' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI+foldMapping '\x1fa8' s = Yield '\x1f60' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI+foldMapping '\x1fa9' s = Yield '\x1f61' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI+foldMapping '\x1faa' s = Yield '\x1f62' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI+foldMapping '\x1fab' s = Yield '\x1f63' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI+foldMapping '\x1fac' s = Yield '\x1f64' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI+foldMapping '\x1fad' s = Yield '\x1f65' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI+foldMapping '\x1fae' s = Yield '\x1f66' (CC s '\x03b9' '\x0000')+-- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI+foldMapping '\x1faf' s = Yield '\x1f67' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI+foldMapping '\x1fb2' s = Yield '\x1f70' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI+foldMapping '\x1fb3' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI+foldMapping '\x1fb4' s = Yield '\x03ac' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI+foldMapping '\x1fb6' s = Yield '\x03b1' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1fb7' s = Yield '\x03b1' (CC s '\x0342' '\x03b9')+-- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI+foldMapping '\x1fbc' s = Yield '\x03b1' (CC s '\x03b9' '\x0000')+-- GREEK PROSGEGRAMMENI+foldMapping '\x1fbe' s = Yield '\x03b9' (CC s '\x0000' '\x0000')+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI+foldMapping '\x1fc2' s = Yield '\x1f74' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI+foldMapping '\x1fc3' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI+foldMapping '\x1fc4' s = Yield '\x03ae' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER ETA WITH PERISPOMENI+foldMapping '\x1fc6' s = Yield '\x03b7' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1fc7' s = Yield '\x03b7' (CC s '\x0342' '\x03b9')+-- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI+foldMapping '\x1fcc' s = Yield '\x03b7' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA+foldMapping '\x1fd2' s = Yield '\x03b9' (CC s '\x0308' '\x0300')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA+foldMapping '\x1fd3' s = Yield '\x03b9' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI+foldMapping '\x1fd6' s = Yield '\x03b9' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI+foldMapping '\x1fd7' s = Yield '\x03b9' (CC s '\x0308' '\x0342')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA+foldMapping '\x1fe2' s = Yield '\x03c5' (CC s '\x0308' '\x0300')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA+foldMapping '\x1fe3' s = Yield '\x03c5' (CC s '\x0308' '\x0301')+-- GREEK SMALL LETTER RHO WITH PSILI+foldMapping '\x1fe4' s = Yield '\x03c1' (CC s '\x0313' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI+foldMapping '\x1fe6' s = Yield '\x03c5' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI+foldMapping '\x1fe7' s = Yield '\x03c5' (CC s '\x0308' '\x0342')+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI+foldMapping '\x1ff2' s = Yield '\x1f7c' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI+foldMapping '\x1ff3' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI+foldMapping '\x1ff4' s = Yield '\x03ce' (CC s '\x03b9' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI+foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000')+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI+foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9')+-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI+foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')+-- COPTIC CAPITAL LETTER BOHAIRIC KHEI+foldMapping '\x2cf2' s = Yield '\x2cf3' (CC s '\x0000' '\x0000')+-- LATIN CAPITAL LETTER C WITH BAR+foldMapping '\xa792' s = Yield '\xa793' (CC s '\x0000' '\x0000')+-- LATIN CAPITAL LETTER H WITH HOOK+foldMapping '\xa7aa' s = Yield '\x0266' (CC s '\x0000' '\x0000')+-- LATIN SMALL LIGATURE FF+foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000')+-- LATIN SMALL LIGATURE FI+foldMapping '\xfb01' s = Yield '\x0066' (CC s '\x0069' '\x0000')+-- LATIN SMALL LIGATURE FL+foldMapping '\xfb02' s = Yield '\x0066' (CC s '\x006c' '\x0000')+-- LATIN SMALL LIGATURE FFI+foldMapping '\xfb03' s = Yield '\x0066' (CC s '\x0066' '\x0069')+-- LATIN SMALL LIGATURE FFL+foldMapping '\xfb04' s = Yield '\x0066' (CC s '\x0066' '\x006c')+-- LATIN SMALL LIGATURE LONG S T+foldMapping '\xfb05' s = Yield '\x0073' (CC s '\x0074' '\x0000')+-- LATIN SMALL LIGATURE ST+foldMapping '\xfb06' s = Yield '\x0073' (CC s '\x0074' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN NOW+foldMapping '\xfb13' s = Yield '\x0574' (CC s '\x0576' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN ECH+foldMapping '\xfb14' s = Yield '\x0574' (CC s '\x0565' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN INI+foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000')+-- ARMENIAN SMALL LIGATURE VEW NOW+foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000')+-- ARMENIAN SMALL LIGATURE MEN XEH+foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000')+foldMapping c s = Yield (toLower c) (CC s '\0' '\0')
+ Data/JSString/Internal/Fusion/Common.hs view
@@ -0,0 +1,936 @@+{-# LANGUAGE BangPatterns, MagicHash, RankNTypes #-}++module Data.JSString.Internal.Fusion.Common ( -- * Creation and elimination+ singleton+ , streamList+ , unstreamList+ , streamCString#++ -- * Basic interface+ , cons+ , snoc+ , append+ , head+ , uncons+ , last+ , tail+ , init+ , null+ , lengthI+ , compareLengthI+ , isSingleton++ -- * Transformations+ , map+ , intercalate+ , intersperse++ -- ** Case conversion+ -- $case+ , toCaseFold+ , toLower+ , toTitle+ , toUpper++ -- ** Justification+ , justifyLeftI+ + -- * Folds+ , foldl+ , foldl'+ , foldl1+ , foldl1'+ , foldr+ , foldr1++ -- ** Special folds+ , concat+ , concatMap+ , any+ , all+ , maximum+ , minimum++ -- * Construction+ -- ** Scans+ , scanl++ -- ** Accumulating maps+ -- , mapAccumL++ -- ** Generation and unfolding+ , replicateCharI+ , replicateI+ , unfoldr+ , unfoldrNI++ -- * Substrings+ -- ** Breaking strings+ , take+ , drop+ , takeWhile+ , dropWhile++ -- * Predicates+ , isPrefixOf++ -- * Searching+ , elem+ , filter++ -- * Indexing+ , findBy+ , indexI+ , findIndexI+ , countCharI++ -- * Zipping and unzipping+ , zipWith+ ) where+++import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..),+ Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++),+ (&&), fromIntegral, otherwise)+import qualified Data.List as L+import qualified Prelude as P+import Data.Bits (shiftL)+import Data.Char (isLetter, isSpace)+import Data.Int (Int64)+import Data.JSString.Internal.Fusion.CaseMapping+ (foldMapping, lowerMapping, titleMapping, upperMapping)+import Data.JSString.Internal.Fusion.Types+import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#)+import GHC.Types (Char(..), Int(..))++singleton :: Char -> Stream Char+singleton c = Stream next False+ where next False = Yield c True+ next True = Done+{-# INLINE [0] singleton #-}++streamList :: [a] -> Stream a+{-# INLINE [0] streamList #-}+streamList s = Stream next s+ where next [] = Done+ next (x:xs) = Yield x xs++unstreamList :: Stream a -> [a]+unstreamList (Stream next s0) = unfold s0+ where unfold !s = case next s of+ Done -> []+ Skip s' -> unfold s'+ Yield x s' -> x : unfold s'+{-# INLINE [0] unstreamList #-}++{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-}++-- | Stream the UTF-8-like packed encoding used by GHC to represent+-- constant strings in generated code.+--+-- This encoding uses the byte sequence "\xc0\x80" to represent NUL,+-- and the string is NUL-terminated.+streamCString# :: Addr# -> Stream Char+streamCString# addr = Stream step 0 -- unknownSize+ where+ step !i+ | b == 0 = Done+ | b <= 0x7f = Yield (C# b#) (i+1)+ | b <= 0xdf = let !c = chr $ ((b-0xc0) `shiftL` 6) + next 1+ in Yield c (i+2)+ | b <= 0xef = let !c = chr $ ((b-0xe0) `shiftL` 12) ++ (next 1 `shiftL` 6) ++ next 2+ in Yield c (i+3)+ | otherwise = let !c = chr $ ((b-0xf0) `shiftL` 18) ++ (next 1 `shiftL` 12) ++ (next 2 `shiftL` 6) ++ next 3+ in Yield c (i+4)+ where b = I# (ord# b#)+ next n = I# (ord# (at# (i+n))) - 0x80+ !b# = at# i+ at# (I# i#) = indexCharOffAddr# addr i#+ chr (I# i#) = C# (chr# i#)+{-# INLINE [0] streamCString# #-}++-- ----------------------------------------------------------------------------+-- * Basic stream functions++data C s = C0 !s+ | C1 !s++-- | /O(n)/ Adds a character to the front of a Stream Char.+cons :: Char -> Stream Char -> Stream Char+cons !w (Stream next0 s0) = Stream next (C1 s0)+ where+ next (C1 s) = Yield w (C0 s)+ next (C0 s) = case next0 s of+ Done -> Done+ Skip s' -> Skip (C0 s')+ Yield x s' -> Yield x (C0 s')+{-# INLINE [0] cons #-}++-- | /O(n)/ Adds a character to the end of a stream.+snoc :: Stream Char -> Char -> Stream Char+snoc (Stream next0 xs0) w = Stream next (J xs0)+ where+ next (J xs) = case next0 xs of+ Done -> Yield w N+ Skip xs' -> Skip (J xs')+ Yield x xs' -> Yield x (J xs')+ next N = Done+{-# INLINE [0] snoc #-}++data E l r = L !l+ | R !r++-- | /O(n)/ Appends one Stream to the other.+append :: Stream Char -> Stream Char -> Stream Char+append (Stream next0 s01) (Stream next1 s02) =+ Stream next (L s01)+ where+ next (L s1) = case next0 s1 of+ Done -> Skip (R s02)+ Skip s1' -> Skip (L s1')+ Yield x s1' -> Yield x (L s1')+ next (R s2) = case next1 s2 of+ Done -> Done+ Skip s2' -> Skip (R s2')+ Yield x s2' -> Yield x (R s2')+{-# INLINE [0] append #-}++-- | /O(1)/ Returns the first character of a Text, which must be non-empty.+-- Subject to array fusion.+head :: Stream Char -> Char+head (Stream next s0) = loop_head s0+ where+ loop_head !s = case next s of+ Yield x _ -> x+ Skip s' -> loop_head s'+ Done -> head_empty+{-# INLINE [0] head #-}++head_empty :: a+head_empty = streamError "head" "Empty stream"+{-# NOINLINE head_empty #-}++-- | /O(1)/ Returns the first character and remainder of a 'Stream+-- Char', or 'Nothing' if empty. Subject to array fusion.+uncons :: Stream Char -> Maybe (Char, Stream Char)+uncons (Stream next s0) = loop_uncons s0+ where+ loop_uncons !s = case next s of+ Yield x s1 -> Just (x, Stream next s1)+ Skip s' -> loop_uncons s'+ Done -> Nothing+{-# INLINE [0] uncons #-}++-- | /O(n)/ Returns the last character of a 'Stream Char', which must+-- be non-empty.+last :: Stream Char -> Char+last (Stream next s0) = loop0_last s0+ where+ loop0_last !s = case next s of+ Done -> emptyError "last"+ Skip s' -> loop0_last s'+ Yield x s' -> loop_last x s'+ loop_last !x !s = case next s of+ Done -> x+ Skip s' -> loop_last x s'+ Yield x' s' -> loop_last x' s'+{-# INLINE[0] last #-}++-- | /O(1)/ Returns all characters after the head of a Stream Char, which must+-- be non-empty.+tail :: Stream Char -> Stream Char+tail (Stream next0 s0) = Stream next (C0 s0)+ where+ next (C0 s) = case next0 s of+ Done -> emptyError "tail"+ Skip s' -> Skip (C0 s')+ Yield _ s' -> Skip (C1 s')+ next (C1 s) = case next0 s of+ Done -> Done+ Skip s' -> Skip (C1 s')+ Yield x s' -> Yield x (C1 s')+{-# INLINE [0] tail #-}++data Init s = Init0 !s+ | Init1 {-# UNPACK #-} !Char !s++-- | /O(1)/ Returns all but the last character of a Stream Char, which+-- must be non-empty.+init :: Stream Char -> Stream Char+init (Stream next0 s0) = Stream next (Init0 s0)+ where+ next (Init0 s) = case next0 s of+ Done -> emptyError "init"+ Skip s' -> Skip (Init0 s')+ Yield x s' -> Skip (Init1 x s')+ next (Init1 x s) = case next0 s of+ Done -> Done+ Skip s' -> Skip (Init1 x s')+ Yield x' s' -> Yield x (Init1 x' s')+{-# INLINE [0] init #-}++-- | /O(1)/ Tests whether a Stream Char is empty or not.+null :: Stream Char -> Bool+null (Stream next s0) = loop_null s0+ where+ loop_null !s = case next s of+ Done -> True+ Yield _ _ -> False+ Skip s' -> loop_null s'+{-# INLINE[0] null #-}++-- | /O(n)/ Returns the number of characters in a string.+lengthI :: Integral a => Stream Char -> a+lengthI (Stream next s0) = loop_length 0 s0+ where+ loop_length !z s = case next s of+ Done -> z+ Skip s' -> loop_length z s'+ Yield _ s' -> loop_length (z + 1) s'+{-# INLINE[0] lengthI #-}++-- | /O(n)/ Compares the count of characters in a string to a number.+-- Subject to fusion.+--+-- This function gives the same answer as comparing against the result+-- of 'lengthI', but can short circuit if the count of characters is+-- greater than the number or if the stream can't possibly be as long+-- as the number supplied, and hence be more efficient.+compareLengthI :: Integral a => Stream Char -> a -> Ordering+compareLengthI (Stream next s0) n = loop_cmp 0 s0+ {- case compareSize len (fromIntegral n) of+ Just o -> o+ Nothing -> loop_cmp 0 s0 -}+ where + loop_cmp !z s = case next s of+ Done -> compare z n+ Skip s' -> loop_cmp z s'+ Yield _ s' | z > n -> GT+ | otherwise -> loop_cmp (z + 1) s'+{-# INLINE[0] compareLengthI #-}++-- | /O(n)/ Indicate whether a string contains exactly one element.+isSingleton :: Stream Char -> Bool+isSingleton (Stream next s0) = loop 0 s0+ where+ loop !z s = case next s of+ Done -> z == (1::Int)+ Skip s' -> loop z s'+ Yield _ s'+ | z >= 1 -> False+ | otherwise -> loop (z+1) s'+{-# INLINE[0] isSingleton #-}++-- ----------------------------------------------------------------------------+-- * Stream transformations++-- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@+-- to each element of @xs@.+map :: (Char -> Char) -> Stream Char -> Stream Char+map f (Stream next0 s0) = Stream next s0+ where+ next !s = case next0 s of+ Done -> Done+ Skip s' -> Skip s'+ Yield x s' -> Yield (f x) s'+{-# INLINE [0] map #-}++{-#+ RULES "STREAM map/map fusion" forall f g s.+ map f (map g s) = map (\x -> f (g x)) s+ #-}++data I s = I1 !s+ | I2 !s {-# UNPACK #-} !Char+ | I3 !s++-- | /O(n)/ Take a character and place it between each of the+-- characters of a 'Stream Char'.+intersperse :: Char -> Stream Char -> Stream Char+intersperse c (Stream next0 s0) = Stream next (I1 s0) -- len+ where+ next (I1 s) = case next0 s of+ Done -> Done+ Skip s' -> Skip (I1 s')+ Yield x s' -> Skip (I2 s' x)+ next (I2 s x) = Yield x (I3 s)+ next (I3 s) = case next0 s of+ Done -> Done+ Skip s' -> Skip (I3 s')+ Yield x s' -> Yield c (I2 s' x)+{-# INLINE [0] intersperse #-}++-- ----------------------------------------------------------------------------+-- ** Case conversions (folds)++-- $case+--+-- With Unicode text, it is incorrect to use combinators like @map+-- toUpper@ to case convert each character of a string individually.+-- Instead, use the whole-string case conversion functions from this+-- module. For correctness in different writing systems, these+-- functions may map one input character to two or three output+-- characters.++caseConvert :: (forall s. Char -> s -> Step (CC s) Char)+ -> Stream Char -> Stream Char+caseConvert remap (Stream next0 s0) = Stream next (CC s0 '\0' '\0')+ where+ next (CC s '\0' _) =+ case next0 s of+ Done -> Done+ Skip s' -> Skip (CC s' '\0' '\0')+ Yield c s' -> remap c s'+ next (CC s a b) = Yield a (CC s b '\0')++-- | /O(n)/ Convert a string to folded case. This function is mainly+-- useful for performing caseless (or case insensitive) string+-- comparisons.+--+-- A string @x@ is a caseless match for a string @y@ if and only if:+--+-- @toCaseFold x == toCaseFold y@+--+-- The result string may be longer than the input string, and may+-- differ from applying 'toLower' to the input string. For instance,+-- the Armenian small ligature men now (U+FB13) is case folded to the+-- bigram men now (U+0574 U+0576), while the micro sign (U+00B5) is+-- case folded to the Greek small letter letter mu (U+03BC) instead of+-- itself.+toCaseFold :: Stream Char -> Stream Char+toCaseFold = caseConvert foldMapping+{-# INLINE [0] toCaseFold #-}++-- | /O(n)/ Convert a string to upper case, using simple case+-- conversion. The result string may be longer than the input string.+-- For instance, the German eszett (U+00DF) maps to the two-letter+-- sequence SS.+toUpper :: Stream Char -> Stream Char+toUpper = caseConvert upperMapping+{-# INLINE [0] toUpper #-}++-- | /O(n)/ Convert a string to lower case, using simple case+-- conversion. The result string may be longer than the input string.+-- For instance, the Latin capital letter I with dot above (U+0130)+-- maps to the sequence Latin small letter i (U+0069) followed by+-- combining dot above (U+0307).+toLower :: Stream Char -> Stream Char+toLower = caseConvert lowerMapping+{-# INLINE [0] toLower #-}++-- | /O(n)/ Convert a string to title case, using simple case+-- conversion.+--+-- The first letter of the input is converted to title case, as is+-- every subsequent letter that immediately follows a non-letter.+-- Every letter that immediately follows another letter is converted+-- to lower case.+--+-- The result string may be longer than the input string. For example,+-- the Latin small ligature fl (U+FB02) is converted to the+-- sequence Latin capital letter F (U+0046) followed by Latin small+-- letter l (U+006C).+--+-- /Note/: this function does not take language or culture specific+-- rules into account. For instance, in English, different style+-- guides disagree on whether the book name \"The Hill of the Red+-- Fox\" is correctly title cased—but this function will+-- capitalize /every/ word.+toTitle :: Stream Char -> Stream Char+toTitle (Stream next0 s0) = Stream next (CC (False :*: s0) '\0' '\0')+ where+ next (CC (letter :*: s) '\0' _) =+ case next0 s of+ Done -> Done+ Skip s' -> Skip (CC (letter :*: s') '\0' '\0')+ Yield c s'+ | nonSpace -> if letter+ then lowerMapping c (nonSpace :*: s')+ else titleMapping c (letter' :*: s')+ | otherwise -> Yield c (CC (letter' :*: s') '\0' '\0')+ where nonSpace = P.not (isSpace c)+ letter' = isLetter c+ next (CC s a b) = Yield a (CC s b '\0')+{-# INLINE [0] toTitle #-}++justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char+justifyLeftI k c (Stream next0 s0) =+ Stream next (s0 :*: S1 :*: 0)+ where+ next (s :*: S1 :*: n) =+ case next0 s of+ Done -> next (s :*: S2 :*: n)+ Skip s' -> Skip (s' :*: S1 :*: n)+ Yield x s' -> Yield x (s' :*: S1 :*: n+1)+ next (s :*: S2 :*: n)+ | n < k = Yield c (s :*: S2 :*: n+1)+ | otherwise = Done+ {-# INLINE next #-}+{-# INLINE [0] justifyLeftI #-}++-- ----------------------------------------------------------------------------+-- * Reducing Streams (folds)++-- | foldl, applied to a binary operator, a starting value (typically the+-- left-identity of the operator), and a Stream, reduces the Stream using the+-- binary operator, from left to right.+foldl :: (b -> Char -> b) -> b -> Stream Char -> b+foldl f z0 (Stream next s0) = loop_foldl z0 s0+ where+ loop_foldl z !s = case next s of+ Done -> z+ Skip s' -> loop_foldl z s'+ Yield x s' -> loop_foldl (f z x) s'+{-# INLINE [0] foldl #-}++-- | A strict version of foldl.+foldl' :: (b -> Char -> b) -> b -> Stream Char -> b+foldl' f z0 (Stream next s0) = loop_foldl' z0 s0+ where+ loop_foldl' !z !s = case next s of+ Done -> z+ Skip s' -> loop_foldl' z s'+ Yield x s' -> loop_foldl' (f z x) s'+{-# INLINE [0] foldl' #-}++-- | foldl1 is a variant of foldl that has no starting value argument,+-- and thus must be applied to non-empty Streams.+foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char+foldl1 f (Stream next s0) = loop0_foldl1 s0+ where+ loop0_foldl1 !s = case next s of+ Skip s' -> loop0_foldl1 s'+ Yield x s' -> loop_foldl1 x s'+ Done -> emptyError "foldl1"+ loop_foldl1 z !s = case next s of+ Done -> z+ Skip s' -> loop_foldl1 z s'+ Yield x s' -> loop_foldl1 (f z x) s'+{-# INLINE [0] foldl1 #-}++-- | A strict version of foldl1.+foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char+foldl1' f (Stream next s0) = loop0_foldl1' s0+ where+ loop0_foldl1' !s = case next s of+ Skip s' -> loop0_foldl1' s'+ Yield x s' -> loop_foldl1' x s'+ Done -> emptyError "foldl1"+ loop_foldl1' !z !s = case next s of+ Done -> z+ Skip s' -> loop_foldl1' z s'+ Yield x s' -> loop_foldl1' (f z x) s'+{-# INLINE [0] foldl1' #-}++-- | 'foldr', applied to a binary operator, a starting value (typically the+-- right-identity of the operator), and a stream, reduces the stream using the+-- binary operator, from right to left.+foldr :: (Char -> b -> b) -> b -> Stream Char -> b+foldr f z (Stream next s0) = loop_foldr s0+ where+ loop_foldr !s = case next s of+ Done -> z+ Skip s' -> loop_foldr s'+ Yield x s' -> f x (loop_foldr s')+{-# INLINE [0] foldr #-}++-- | foldr1 is a variant of 'foldr' that has no starting value argument,+-- and thus must be applied to non-empty streams.+-- Subject to array fusion.+foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char+foldr1 f (Stream next s0) = loop0_foldr1 s0+ where+ loop0_foldr1 !s = case next s of+ Done -> emptyError "foldr1"+ Skip s' -> loop0_foldr1 s'+ Yield x s' -> loop_foldr1 x s'++ loop_foldr1 x !s = case next s of+ Done -> x+ Skip s' -> loop_foldr1 x s'+ Yield x' s' -> f x (loop_foldr1 x' s')+{-# INLINE [0] foldr1 #-}++intercalate :: Stream Char -> [Stream Char] -> Stream Char+intercalate s = concat . (L.intersperse s)+{-# INLINE [0] intercalate #-}++-- ----------------------------------------------------------------------------+-- ** Special folds++-- | /O(n)/ Concatenate a list of streams. Subject to array fusion.+concat :: [Stream Char] -> Stream Char+concat = L.foldr append empty+{-# INLINE [0] concat #-}++-- | Map a function over a stream that results in a stream and concatenate the+-- results.+concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char+concatMap f = foldr (append . f) empty+{-# INLINE [0] concatMap #-}++-- | /O(n)/ any @p @xs determines if any character in the stream+-- @xs@ satisifes the predicate @p@.+any :: (Char -> Bool) -> Stream Char -> Bool+any p (Stream next0 s0) = loop_any s0+ where+ loop_any !s = case next0 s of+ Done -> False+ Skip s' -> loop_any s'+ Yield x s' | p x -> True+ | otherwise -> loop_any s'+{-# INLINE [0] any #-}++-- | /O(n)/ all @p @xs determines if all characters in the 'Text'+-- @xs@ satisify the predicate @p@.+all :: (Char -> Bool) -> Stream Char -> Bool+all p (Stream next0 s0) = loop_all s0+ where+ loop_all !s = case next0 s of+ Done -> True+ Skip s' -> loop_all s'+ Yield x s' | p x -> loop_all s'+ | otherwise -> False+{-# INLINE [0] all #-}++-- | /O(n)/ maximum returns the maximum value from a stream, which must be+-- non-empty.+maximum :: Stream Char -> Char+maximum (Stream next0 s0) = loop0_maximum s0+ where+ loop0_maximum !s = case next0 s of+ Done -> emptyError "maximum"+ Skip s' -> loop0_maximum s'+ Yield x s' -> loop_maximum x s'+ loop_maximum !z !s = case next0 s of+ Done -> z+ Skip s' -> loop_maximum z s'+ Yield x s'+ | x > z -> loop_maximum x s'+ | otherwise -> loop_maximum z s'+{-# INLINE [0] maximum #-}++-- | /O(n)/ minimum returns the minimum value from a 'Text', which must be+-- non-empty.+minimum :: Stream Char -> Char+minimum (Stream next0 s0) = loop0_minimum s0+ where+ loop0_minimum !s = case next0 s of+ Done -> emptyError "minimum"+ Skip s' -> loop0_minimum s'+ Yield x s' -> loop_minimum x s'+ loop_minimum !z !s = case next0 s of+ Done -> z+ Skip s' -> loop_minimum z s'+ Yield x s'+ | x < z -> loop_minimum x s'+ | otherwise -> loop_minimum z s'+{-# INLINE [0] minimum #-}++-- -----------------------------------------------------------------------------+-- * Building streams++scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char+scanl f z0 (Stream next0 s0) = Stream next (S1 :*: z0 :*: s0)+ where+ {-# INLINE next #-}+ next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s)+ next (S2 :*: z :*: s) = case next0 s of+ Yield x s' -> let !x' = f z x+ in Yield x' (S2 :*: x' :*: s')+ Skip s' -> Skip (S2 :*: z :*: s')+ Done -> Done+{-# INLINE [0] scanl #-}++-- -----------------------------------------------------------------------------+-- ** Accumulating maps++{-+-- | /O(n)/ Like a combination of 'map' and 'foldl'. Applies a+-- function to each element of a stream, passing an accumulating+-- parameter from left to right, and returns a final stream.+--+-- /Note/: Unlike the version over lists, this function does not+-- return a final value for the accumulator, because the nature of+-- streams precludes it.+mapAccumL :: (a -> b -> (a,b)) -> a -> Stream b -> Stream b+mapAccumL f z0 (Stream next0 s0 len) = Stream next (s0 :*: z0) len -- HINT depends on f+ where+ {-# INLINE next #-}+ next (s :*: z) = case next0 s of+ Yield x s' -> let (z',y) = f z x+ in Yield y (s' :*: z')+ Skip s' -> Skip (s' :*: z)+ Done -> Done+{-# INLINE [0] mapAccumL #-}+-}++-- -----------------------------------------------------------------------------+-- ** Generating and unfolding streams++replicateCharI :: Integral a => a -> Char -> Stream Char+replicateCharI n c+ | n < 0 = empty+ | otherwise = Stream next 0 -- HINT maybe too low+ where+ next i | i >= n = Done+ | otherwise = Yield c (i + 1)+{-# INLINE [0] replicateCharI #-}++data RI s = RI !s {-# UNPACK #-} !Int64++replicateI :: Int64 -> Stream Char -> Stream Char+replicateI n (Stream next0 s0) =+ Stream next (RI s0 0)+ where+ next (RI s k)+ | k >= n = Done+ | otherwise = case next0 s of+ Done -> Skip (RI s0 (k+1))+ Skip s' -> Skip (RI s' k)+ Yield x s' -> Yield x (RI s' k)+{-# INLINE [0] replicateI #-}++-- | /O(n)/, where @n@ is the length of the result. The unfoldr function+-- is analogous to the List 'unfoldr'. unfoldr builds a stream+-- from a seed value. The function takes the element and returns+-- Nothing if it is done producing the stream or returns Just+-- (a,b), in which case, a is the next Char in the string, and b is+-- the seed value for further production.+unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char+unfoldr f s0 = Stream next s0+ where+ {-# INLINE next #-}+ next !s = case f s of+ Nothing -> Done+ Just (w, s') -> Yield w s'+{-# INLINE [0] unfoldr #-}++-- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed+-- value. However, the length of the result is limited by the+-- first argument to 'unfoldrNI'. This function is more efficient than+-- 'unfoldr' when the length of the result is known.+unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char+unfoldrNI n f s0 | n < 0 = empty+ | otherwise = Stream next (0 :*: s0)+ where+ {-# INLINE next #-}+ next (z :*: s) = case f s of+ Nothing -> Done+ Just (w, s') | z >= n -> Done+ | otherwise -> Yield w ((z + 1) :*: s')+{-# INLINE unfoldrNI #-}++-------------------------------------------------------------------------------+-- * Substreams++-- | /O(n)/ take n, applied to a stream, returns the prefix of the+-- stream of length @n@, or the stream itself if @n@ is greater than the+-- length of the stream.+take :: Integral a => a -> Stream Char -> Stream Char+take n0 (Stream next0 s0) =+ Stream next (n0 :*: s0)+ where+ {-# INLINE next #-}+ next (n :*: s) | n <= 0 = Done+ | otherwise = case next0 s of+ Done -> Done+ Skip s' -> Skip (n :*: s')+ Yield x s' -> Yield x ((n-1) :*: s')+{-# INLINE [0] take #-}++-- | /O(n)/ drop n, applied to a stream, returns the suffix of the+-- stream after the first @n@ characters, or the empty stream if @n@+-- is greater than the length of the stream.+drop :: Integral a => a -> Stream Char -> Stream Char+drop n0 (Stream next0 s0) =+ Stream next (J n0 :*: s0)+ where+ {-# INLINE next #-}+ next (J n :*: s)+ | n <= 0 = Skip (N :*: s)+ | otherwise = case next0 s of+ Done -> Done+ Skip s' -> Skip (J n :*: s')+ Yield _ s' -> Skip (J (n-1) :*: s')+ next (N :*: s) = case next0 s of+ Done -> Done+ Skip s' -> Skip (N :*: s')+ Yield x s' -> Yield x (N :*: s')+{-# INLINE [0] drop #-}++-- | takeWhile, applied to a predicate @p@ and a stream, returns the+-- longest prefix (possibly empty) of elements that satisfy p.+takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char+takeWhile p (Stream next0 s0) = Stream next s0+ where+ {-# INLINE next #-}+ next !s = case next0 s of+ Done -> Done+ Skip s' -> Skip s'+ Yield x s' | p x -> Yield x s'+ | otherwise -> Done+{-# INLINE [0] takeWhile #-}++-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.+dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char+dropWhile p (Stream next0 s0) = Stream next (S1 :*: s0)+ where+ {-# INLINE next #-}+ next (S1 :*: s) = case next0 s of+ Done -> Done+ Skip s' -> Skip (S1 :*: s')+ Yield x s' | p x -> Skip (S1 :*: s')+ | otherwise -> Yield x (S2 :*: s')+ next (S2 :*: s) = case next0 s of+ Done -> Done+ Skip s' -> Skip (S2 :*: s')+ Yield x s' -> Yield x (S2 :*: s')+{-# INLINE [0] dropWhile #-}++-- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns+-- 'True' iff the first is a prefix of the second.+isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool+isPrefixOf (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)+ where+ loop Done _ = True+ loop _ Done = False+ loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')+ loop (Skip s1') x2 = loop (next1 s1') x2+ loop x1 (Skip s2') = loop x1 (next2 s2')+ loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&+ loop (next1 s1') (next2 s2')+{-# INLINE [0] isPrefixOf #-}++-- ----------------------------------------------------------------------------+-- * Searching++-------------------------------------------------------------------------------+-- ** Searching by equality++-- | /O(n)/ elem is the stream membership predicate.+elem :: Char -> Stream Char -> Bool+elem w (Stream next s0) = loop_elem s0+ where+ loop_elem !s = case next s of+ Done -> False+ Skip s' -> loop_elem s'+ Yield x s' | x == w -> True+ | otherwise -> loop_elem s'+{-# INLINE [0] elem #-}++-------------------------------------------------------------------------------+-- ** Searching with a predicate++-- | /O(n)/ The 'findBy' function takes a predicate and a stream,+-- and returns the first element in matching the predicate, or 'Nothing'+-- if there is no such element.++findBy :: (Char -> Bool) -> Stream Char -> Maybe Char+findBy p (Stream next s0) = loop_find s0+ where+ loop_find !s = case next s of+ Done -> Nothing+ Skip s' -> loop_find s'+ Yield x s' | p x -> Just x+ | otherwise -> loop_find s'+{-# INLINE [0] findBy #-}++-- | /O(n)/ Stream index (subscript) operator, starting from 0.+indexI :: Integral a => Stream Char -> a -> Char+indexI (Stream next s0) n0+ | n0 < 0 = streamError "index" "Negative index"+ | otherwise = loop_index n0 s0+ where+ loop_index !n !s = case next s of+ Done -> streamError "index" "Index too large"+ Skip s' -> loop_index n s'+ Yield x s' | n == 0 -> x+ | otherwise -> loop_index (n-1) s'+{-# INLINE [0] indexI #-}++-- | /O(n)/ 'filter', applied to a predicate and a stream,+-- returns a stream containing those characters that satisfy the+-- predicate.+filter :: (Char -> Bool) -> Stream Char -> Stream Char+filter p (Stream next0 s0) = Stream next s0+ where+ next !s = case next0 s of+ Done -> Done+ Skip s' -> Skip s'+ Yield x s' | p x -> Yield x s'+ | otherwise -> Skip s'+{-# INLINE [0] filter #-}++{-# RULES+ "STREAM filter/filter fusion" forall p q s.+ filter p (filter q s) = filter (\x -> q x && p x) s+ #-}++-- | The 'findIndexI' function takes a predicate and a stream and+-- returns the index of the first element in the stream satisfying the+-- predicate.+findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a+findIndexI p s = case findIndicesI p s of+ (i:_) -> Just i+ _ -> Nothing+{-# INLINE [0] findIndexI #-}++-- | The 'findIndicesI' function takes a predicate and a stream and+-- returns all indices of the elements in the stream satisfying the+-- predicate.+findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a]+findIndicesI p (Stream next s0) = loop_findIndex 0 s0+ where+ loop_findIndex !i !s = case next s of+ Done -> []+ Skip s' -> loop_findIndex i s' -- hmm. not caught by QC+ Yield x s' | p x -> i : loop_findIndex (i+1) s'+ | otherwise -> loop_findIndex (i+1) s'+{-# INLINE [0] findIndicesI #-}++-------------------------------------------------------------------------------+-- * Zipping++-- | zipWith generalises 'zip' by zipping with the function given as+-- the first argument, instead of a tupling function.+zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b+zipWith f (Stream next0 sa0) (Stream next1 sb0) =+ Stream next (sa0 :*: sb0 :*: N)+ where+ next (sa :*: sb :*: N) = case next0 sa of+ Done -> Done+ Skip sa' -> Skip (sa' :*: sb :*: N)+ Yield a sa' -> Skip (sa' :*: sb :*: J a)++ next (sa' :*: sb :*: J a) = case next1 sb of+ Done -> Done+ Skip sb' -> Skip (sa' :*: sb' :*: J a)+ Yield b sb' -> Yield (f a b) (sa' :*: sb' :*: N)+{-# INLINE [0] zipWith #-}++-- | /O(n)/ The 'countCharI' function returns the number of times the+-- query element appears in the given stream.+countCharI :: Integral a => Char -> Stream Char -> a+countCharI a (Stream next s0) = loop 0 s0+ where+ loop !i !s = case next s of+ Done -> i+ Skip s' -> loop i s'+ Yield x s' | a == x -> loop (i+1) s'+ | otherwise -> loop i s'+{-# INLINE [0] countCharI #-}++streamError :: String -> String -> a+streamError func msg = P.error $ "Data.Text.Internal.Fusion.Common." ++ func ++ ": " ++ msg++emptyError :: String -> a+emptyError func = internalError func "Empty input"++internalError :: String -> a+internalError func = streamError func "Internal error"
+ Data/JSString/Internal/Fusion/Types.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE BangPatterns, ExistentialQuantification #-}+-- |+-- Module : Data.Text.Internal.Fusion.Types+-- Copyright : (c) Tom Harper 2008-2009,+-- (c) Bryan O'Sullivan 2009,+-- (c) Duncan Coutts 2009,+-- (c) Jasper Van der Jeugt 2011+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- /Warning/: this is an internal module, and does not have a stable+-- API or name. Functions in this module may not check or enforce+-- preconditions expected by public modules. Use at your own risk!+--+-- Core stream fusion functionality for text.++module Data.JSString.Internal.Fusion.Types+ (+ CC(..)+ , M(..)+ , M8+ , PairS(..)+ , RS(..)+ , Step(..)+ , Stream(..)+ , Switch(..)+ , empty+ ) where++-- import Data.Text.Internal.Fusion.Size+import Data.Word (Word8)++-- | Specialised tuple for case conversion.+data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char++-- | Specialised, strict Maybe-like type.+data M a = N+ | J !a++type M8 = M Word8++-- Restreaming state.+data RS s+ = RS0 !s+ | RS1 !s {-# UNPACK #-} !Word8+ | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+ | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8++infixl 2 :*:+data PairS a b = !a :*: !b+ -- deriving (Eq, Ord, Show)++-- | Allow a function over a stream to switch between two states.+data Switch = S1 | S2++data Step s a = Done+ | Skip !s+ | Yield !a !s++{-+instance (Show a) => Show (Step s a)+ where show Done = "Done"+ show (Skip _) = "Skip"+ show (Yield x _) = "Yield " ++ show x+-}++instance (Eq a) => Eq (Stream a) where+ (==) = eq++instance (Ord a) => Ord (Stream a) where+ compare = cmp++-- The length hint in a Stream has two roles. If its value is zero,+-- we trust it, and treat the stream as empty. Otherwise, we treat it+-- as a hint: it should usually be accurate, so we use it when+-- unstreaming to decide what size array to allocate. However, the+-- unstreaming functions must be able to cope with the hint being too+-- small or too large.++data Stream a =+ forall s. Stream+ (s -> Step s a) -- stepper function+ !s -- current state++-- | /O(n)/ Determines if two streams are equal.+eq :: (Eq a) => Stream a -> Stream a -> Bool+eq (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)+ where+ loop Done Done = True+ loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')+ loop (Skip s1') x2 = loop (next1 s1') x2+ loop x1 (Skip s2') = loop x1 (next2 s2')+ loop Done _ = False+ loop _ Done = False+ loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&+ loop (next1 s1') (next2 s2')+{-# INLINE [0] eq #-}++cmp :: (Ord a) => Stream a -> Stream a -> Ordering+cmp (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)+ where+ loop Done Done = EQ+ loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')+ loop (Skip s1') x2 = loop (next1 s1') x2+ loop x1 (Skip s2') = loop x1 (next2 s2')+ loop Done _ = LT+ loop _ Done = GT+ loop (Yield x1 s1') (Yield x2 s2') =+ case compare x1 x2 of+ EQ -> loop (next1 s1') (next2 s2')+ other -> other+{-# INLINE [0] cmp #-}++-- | The empty stream.+empty :: Stream a+empty = Stream next ()+ where next _ = Done+{-# INLINE [0] empty #-}
+ Data/JSString/Internal/Search.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples, TypeFamilies,+ ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes,+ GHCForeignImportPrim+ #-}++module Data.JSString.Internal.Search ( indices+ ) where++import GHC.Exts (Int#, (+#), Int(..))+import Data.JSString++-- returns uncorrected offsets in the String+indices :: JSString -> JSString -> [Int]+indices needle haystack = go 0#+ where+ go i = case js_indexOf needle i haystack of+ -1# -> []+ n -> I# n : go (n +# 1#)++foreign import javascript unsafe+ "$3.indexOf($1,$2)"+ js_indexOf :: JSString -> Int# -> JSString -> Int#
+ Data/JSString/Internal/Type.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples, MagicHash,+ BangPatterns, ForeignFunctionInterface, JavaScriptFFI #-}+{-# OPTIONS_HADDOCK not-home #-}+module Data.JSString.Internal.Type ( JSString(..)+ , empty+ , empty_+ , safe+ , firstf+ ) where+ + {-+ -- * Construction+ , text+ , textP+ -- * Safety+ , safe+ -- * Code that must be here for accessibility+ , empty+ , empty_+ -- * Utilities+ , firstf+ -- * Checked multiplication+ , mul+ , mul32+ , mul64+ -- * Debugging+ , showText++ ) where+-}+import Control.DeepSeq++import Data.Bits+import Data.Int (Int32, Int64)+-- import Data.Text.Internal.Unsafe.Char (ord)+import Data.Typeable (Typeable)+import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#)++import GHCJS.Prim (JSVal)++import GHCJS.Internal.Types++-- | A wrapper around a JavaScript string+newtype JSString = JSString JSVal+instance IsJSVal JSString++instance NFData JSString where rnf !x = ()++foreign import javascript unsafe+ "$r = '';" js_empty :: JSString++-- | /O(1)/ The empty 'JSString'.+empty :: JSString+empty = js_empty+{-# INLINE [1] empty #-}++-- | A non-inlined version of 'empty'.+empty_ :: JSString+empty_ = js_empty+{-# NOINLINE empty_ #-}++safe :: Char -> Char+safe c@(C# cc)+ | isTrue# (andI# (ord# cc) 0x1ff800# /=# 0xd800#) = c+ | otherwise = '\xfffd'+{-# INLINE [0] safe #-}+++-- | Apply a function to the first element of an optional pair.+firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)+firstf f (Just (a, b)) = Just (f a, b)+firstf _ Nothing = Nothing++{-+-- | Checked multiplication. Calls 'error' if the result would+-- overflow.+mul :: Int -> Int -> Int+#if WORD_SIZE_IN_BITS == 64+mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b+#else+mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b+#endif+{-# INLINE mul #-}+infixl 7 `mul`++-- | Checked multiplication. Calls 'error' if the result would+-- overflow.+mul64 :: Int64 -> Int64 -> Int64+mul64 a b+ | a >= 0 && b >= 0 = mul64_ a b+ | a >= 0 = -mul64_ a (-b)+ | b >= 0 = -mul64_ (-a) b+ | otherwise = mul64_ (-a) (-b)+{-# INLINE mul64 #-}+infixl 7 `mul64`++mul64_ :: Int64 -> Int64 -> Int64+mul64_ a b+ | ahi > 0 && bhi > 0 = error "overflow"+ | top > 0x7fffffff = error "overflow"+ | total < 0 = error "overflow"+ | otherwise = total+ where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)+ (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)+ top = ahi * blo + alo * bhi+ total = (top `shiftL` 32) + alo * blo+{-# INLINE mul64_ #-}++-- | Checked multiplication. Calls 'error' if the result would+-- overflow.+mul32 :: Int32 -> Int32 -> Int32+mul32 a b = case fromIntegral a * fromIntegral b of+ ab | ab < min32 || ab > max32 -> error "overflow"+ | otherwise -> fromIntegral ab+ where min32 = -0x80000000 :: Int64+ max32 = 0x7fffffff+{-# INLINE mul32 #-}+infixl 7 `mul32`+-}
+ Data/JSString/Raw.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI,+ MagicHash, UnboxedTuples, UnliftedFFITypes, GHCForeignImportPrim+ #-}++{-+ Low level bindings for JavaScript strings. These expose the underlying+ encoding. Use Data.JSString for + -}+module Data.JSString.Raw ( rawHead+ , rawTail+ , rawInit+ , rawLast+ , rawLength+ , rawTake+ , rawDrop+ , rawTakeEnd+ , rawDropEnd+ , rawChunksOf+ , rawChunksOf'+ ) where++import GHC.Exts+ ( Int(..), Int#, Char(..)+ , negateInt#+ , (+#), (-#), (>=#), (<#)+ , isTrue#, chr#)+import qualified GHC.Exts as Exts+import GHCJS.Prim (JSVal)++import Unsafe.Coerce++import Data.JSString.Internal.Type+++rawLength :: JSString -> Int+rawLength x = I# (js_length x)+{-# INLINE rawLength #-}++rawHead :: JSString -> Char+rawHead x+ | js_null x = emptyError "rawHead"+ | otherwise = C# (chr# (js_codePointAt 0# x))+{-# INLINE rawHead #-}++unsafeRawHead :: JSString -> Char+unsafeRawHead x = C# (chr# (js_codePointAt 0# x))+{-# INLINE unsafeRawHead #-}++rawLast :: JSString -> Char+rawLast x+ | js_null x = emptyError "rawLast"+ | otherwise = C# (chr# (js_charCodeAt (js_length x -# 1#) x))+{-# INLINE rawLast #-}++unsafeRawLast :: JSString -> Char+unsafeRawLast x = C# (chr# (js_charCodeAt (js_length x -# 1#) x))+{-# INLINE unsafeRawLast #-}++rawTail :: JSString -> JSString+rawTail x+ | js_null x = emptyError "rawTail"+ | otherwise = JSString $ js_tail x+{-# INLINE rawTail #-}++unsafeRawTail :: JSString -> JSString+unsafeRawTail x = JSString $ js_tail x+{-# INLINE unsafeRawTail #-}++rawInit :: JSString -> JSString+rawInit x = js_substr 0# (js_length x -# 1#) x+{-# INLINE rawInit #-}++unsafeRawInit :: JSString -> JSString+unsafeRawInit x = js_substr 0# (js_length x -# 1#) x+{-# INLINE unsafeRawInit #-}++unsafeRawIndex :: Int -> JSString -> Char+unsafeRawIndex (I# n) x = C# (chr# (js_charCodeAt n x))+{-# INLINE unsafeRawIndex #-}++rawIndex :: Int -> JSString -> Char+rawIndex (I# n) x+ | isTrue# (n <# 0#) || isTrue# (n >=# js_length x) =+ overflowError "rawIndex"+ | otherwise = C# (chr# (js_charCodeAt n x))+{-# INLINE rawIndex #-}+ +rawTake :: Int -> JSString -> JSString+rawTake (I# n) x = js_substr 0# n x+{-# INLINE rawTake #-}++rawDrop :: Int -> JSString -> JSString+rawDrop (I# n) x = js_substr1 n x+{-# INLINE rawDrop #-}++rawTakeEnd :: Int -> JSString -> JSString+rawTakeEnd (I# k) x = js_slice1 (negateInt# k) x+{-# INLINE rawTakeEnd #-}++rawDropEnd :: Int -> JSString -> JSString+rawDropEnd (I# k) x = js_substr 0# (js_length x -# k) x+{-# INLINE rawDropEnd #-}++rawChunksOf :: Int -> JSString -> [JSString]+rawChunksOf (I# k) x =+ let l = js_length x+ go i = case i >=# l of+ 0# -> js_substr i k x : go (i +# k)+ _ -> []+ in go 0#+{-# INLINE rawChunksOf #-}++rawChunksOf' :: Int -> JSString -> [JSString]+rawChunksOf' (I# k) x = unsafeCoerce (js_rawChunksOf k x)+{-# INLINE rawChunksOf' #-}++rawSplitAt :: Int -> JSString -> (JSString, JSString)+rawSplitAt (I# k) x = (js_substr 0# k x, js_substr1 k x)+{-# INLINE rawSplitAt #-}++emptyError :: String -> a+emptyError fun = error $ "Data.JSString.Raw." ++ fun ++ ": empty input"++overflowError :: String -> a+overflowError fun = error $ "Data.JSString.Raw." ++ fun ++ ": size overflow"++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$1===''" js_null :: JSString -> Bool+foreign import javascript unsafe+ "$1.length" js_length :: JSString -> Int#+foreign import javascript unsafe+ "$3.substr($1,$2)" js_substr :: Int# -> Int# -> JSString -> JSString+foreign import javascript unsafe+ "$2.substr($1)" js_substr1 :: Int# -> JSString -> JSString+foreign import javascript unsafe+ "$3.slice($1,$2)" js_slice :: Int# -> Int# -> JSString -> JSString+foreign import javascript unsafe+ "$2.slice($1)" js_slice1 :: Int# -> JSString -> JSString+foreign import javascript unsafe+ "$3.indexOf($1,$2)" js_indexOf :: JSString -> Int# -> JSString -> Int#+foreign import javascript unsafe+ "$2.indexOf($1)" js_indexOf1 :: JSString -> JSString -> Int#+foreign import javascript unsafe+ "$2.charCodeAt($1)" js_charCodeAt :: Int# -> JSString -> Int#+foreign import javascript unsafe+ "$2.codePointAt($1)" js_codePointAt :: Int# -> JSString -> Int#+foreign import javascript unsafe+ "$hsRawChunksOf" js_rawChunksOf :: Int# -> JSString -> Exts.Any -- [JSString]+foreign import javascript unsafe+ "h$jsstringTail" js_tail :: JSString -> JSVal -- null for empty string+
+ Data/JSString/Read.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes,+ GHCForeignImportPrim, UnboxedTuples, BangPatterns,+ MagicHash+ #-}+module Data.JSString.Read ( isInteger+ , isNatural+ , readInt+ , readIntMaybe+ , lenientReadInt+ , readInt64+ , readInt64Maybe+ , readWord64+ , readWord64Maybe+ , readDouble+ , readDoubleMaybe+ , readInteger+ , readIntegerMaybe+ ) where++import GHCJS.Types++import GHC.Exts (Any, Int#, Int64#, Word64#, Int(..))+import GHC.Int (Int64(..))+import GHC.Word (Word64(..))+import Unsafe.Coerce+import Data.Maybe+import Data.JSString++{- |+ Returns whether the JSString represents an integer at base 10+ -}+isInteger :: JSString -> Bool+isInteger j = js_isInteger j+{-# INLINE isInteger #-}++{- |+ Returns whether the JSString represents a natural number at base 10+ (including 0)+ -}+isNatural :: JSString -> Bool+isNatural j = js_isInteger j+{-# INLINE isNatural #-}++{- |+ Convert a JSString to an Int, throwing an exception if it cannot+ be converted. Leading spaces are allowed. The function ignores+ trailing non-digit characters.+ -}+lenientReadInt :: JSString -> Int+lenientReadInt j = fromMaybe (readError "lenientReadInt") (lenientReadIntMaybe j)+{-# INLINE lenientReadInt #-}++{- |+ Convert a JSString to an Int, returning Nothing if it cannot+ be converted. Leading spaces are allowed. The function ignores+ trailing non-digit characters.+ -}+lenientReadIntMaybe :: JSString -> Maybe Int+lenientReadIntMaybe j = convertNullMaybe js_lenientReadInt j+{-# INLINE lenientReadIntMaybe #-}++{- |+ Convert a JSString to an Int, throwing an exception if it cannot+ be converted. Leading spaces and trailing non-digit characters+ are not allowed.+ -}+readInt :: JSString -> Int+readInt j = fromMaybe (readError "readInt") (readIntMaybe j)+{-# INLINE readInt #-}++{- |+ Convert a JSString to an Int, returning Nothing if it cannot+ be converted. Leading spaces and trailing non-digit characters+ are not allowed.+ -}+readIntMaybe :: JSString -> Maybe Int+readIntMaybe j = convertNullMaybe js_readInt j+{-# INLINE readIntMaybe #-}++readInt64 :: JSString -> Int64+readInt64 j = fromMaybe (readError "readInt64") (readInt64Maybe j)+{-# INLINE readInt64 #-}++readInt64Maybe :: JSString -> Maybe Int64+readInt64Maybe j = case js_readInt64 j of+ (# 0#, _ #) -> Nothing+ (# _, x #) -> Just (I64# x)+{-# INLINE readInt64Maybe #-}++readWord64 :: JSString -> Word64+readWord64 j = fromMaybe (readError "readWord64") (readWord64Maybe j)+{-# INLINE readWord64 #-}++readWord64Maybe :: JSString -> Maybe Word64+readWord64Maybe j = case js_readWord64 j of+ (# 0#, _ #) -> Nothing+ (# _, x #) -> Just (W64# x)+{-# INLINE readWord64Maybe #-}+++{- |+ Convert a JSString to an Int, throwing an exception if it cannot+ be converted. Leading spaces are allowed. The function ignores+ trailing non-digit characters.+ -}+readDouble :: JSString -> Double+readDouble j = fromMaybe (readError "readDouble") (readDoubleMaybe j)+{-# INLINE readDouble #-}++{- |+ Convert a JSString to a Double, returning Nothing if it cannot+ be converted. Leading spaces are allowed. The function ignores+ trailing non-digit characters.+ -}++readDoubleMaybe :: JSString -> Maybe Double+readDoubleMaybe j = convertNullMaybe js_readDouble j+{-# INLINE readDoubleMaybe #-}++{- |+ Convert a JSString to a Double, returning Nothing if it cannot+ be converted. Leading spaces and trailing non-digit characters+ are not allowed.+ -}+strictReadDoubleMaybe :: JSString -> Maybe Double+strictReadDoubleMaybe j = convertNullMaybe js_readDouble j+{-# INLINE strictReadDoubleMaybe #-}++readInteger :: JSString -> Integer+readInteger j = fromMaybe (readError "readInteger") (readIntegerMaybe j)+{-# INLINE readInteger #-}++readIntegerMaybe :: JSString -> Maybe Integer+readIntegerMaybe j = convertNullMaybe js_readInteger j+{-# INLINE readIntegerMaybe #-}++-- ----------------------------------------------------------------------------++convertNullMaybe :: (JSString -> JSVal) -> JSString -> Maybe a+convertNullMaybe f j+ | js_isNull r = Nothing+ | otherwise = Just (unsafeCoerce (js_toHeapObject r))+ where+ r = f j+{-# INLINE convertNullMaybe #-}++readError :: String -> a+readError xs = error ("Data.JSString.Read." ++ xs)++-- ----------------------------------------------------------------------------++foreign import javascript unsafe+ "$r = $1===null;" js_isNull :: JSVal -> Bool+foreign import javascript unsafe+ "$r=$1;" js_toHeapObject :: JSVal -> Any+foreign import javascript unsafe+ "h$jsstringReadInteger" js_readInteger :: JSString -> JSVal+foreign import javascript unsafe+ "h$jsstringReadInt" js_readInt :: JSString -> JSVal+foreign import javascript unsafe+ "h$jsstringLenientReadInt" js_lenientReadInt :: JSString -> JSVal+foreign import javascript unsafe+ "h$jsstringReadInt64" js_readInt64 :: JSString -> (# Int#, Int64# #)+foreign import javascript unsafe+ "h$jsstringReadWord64" js_readWord64 :: JSString -> (# Int#, Word64# #)+foreign import javascript unsafe+ "h$jsstringReadDouble" js_readDouble :: JSString -> JSVal+foreign import javascript unsafe+ "h$jsstringIsInteger" js_isInteger :: JSString -> Bool+foreign import javascript unsafe+ "h$jsstringIsNatural" js_isNatural :: JSString -> Bool
+ Data/JSString/RealFloat.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, MagicHash,+ UnliftedFFITypes+ #-}+module Data.JSString.RealFloat ( FPFormat(..)+ , realFloat+ , formatRealFloat+ , formatDouble+ , formatFloat+ ) where++import GHC.Exts (Int#, Float#, Double#, Int(..), Float(..), Double(..))++import Data.JSString++-- | Control the rendering of floating point numbers.+data FPFormat = Exponent+ -- ^ Scientific notation (e.g. @2.3e123@).+ | Fixed+ -- ^ Standard decimal notation.+ | Generic+ -- ^ Use decimal notation for values between @0.1@ and+ -- @9,999,999@, and scientific notation otherwise.+ deriving (Enum, Read, Show)++realFloat :: (RealFloat a) => a -> JSString+realFloat = error "Data.JSString.RealFloat.realFloat not yet implemented"+{-# RULES "realFloat/Double" realFloat = genericDouble #-}+{-# RULES "realFoat/Float" realFloat = genericFloat #-}+{-# SPECIALIZE realFloat :: Double -> JSString #-}+{-# SPECIALIZE realFloat :: Float -> JSString #-}+{-# NOINLINE realFloat #-}++formatRealFloat :: (RealFloat a)+ => FPFormat+ -> Maybe Int+ -> a+ -> JSString+formatRealFloat = error "Data.JSString.RealFloat.formatRealFloat not yet implemented"+{-# RULES "formatRealFloat/Double" formatRealFloat = formatDouble #-}+{-# RULES "formatRealFloat/Float" formatRealFloat = formatFloat #-}+{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Double -> JSString #-}+{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Float -> JSString #-}+{-# NOINLINE formatRealFloat #-}++genericDouble :: Double -> JSString+genericDouble (D# d) = js_doubleGeneric -1# d+{-# INLINE genericDouble #-}++genericFloat :: Float -> JSString+genericFloat (F# f) = js_floatGeneric -1# f+{-# INLINE genericFloat #-}++formatDouble :: FPFormat -> Maybe Int -> Double -> JSString+formatDouble fmt Nothing (D# d)+ = case fmt of+ Fixed -> js_doubleToFixed -1# d+ Exponent -> js_doubleToExponent -1# d+ Generic -> js_doubleGeneric -1# d+formatDouble fmt (Just (I# decs)) (D# d)+ = case fmt of+ Fixed -> js_doubleToFixed decs d+ Exponent -> js_doubleToExponent decs d+ Generic -> js_doubleGeneric decs d+{-# INLINE formatDouble #-}++formatFloat :: FPFormat -> Maybe Int -> Float -> JSString+formatFloat fmt Nothing (F# f)+ = case fmt of+ Fixed -> js_floatToFixed -1# f+ Exponent -> js_floatToExponent -1# f+ Generic -> js_floatGeneric -1# f+formatFloat fmt (Just (I# decs)) (F# f)+ = case fmt of+ Fixed -> js_floatToFixed decs f+ Exponent -> js_floatToExponent decs f+ Generic -> js_floatGeneric decs f+{-# INLINE formatFloat #-}+++foreign import javascript unsafe+ "h$jsstringDoubleToFixed"+ js_doubleToFixed :: Int# -> Double# -> JSString+foreign import javascript unsafe+ "h$jsstringDoubleToFixed"+ js_floatToFixed :: Int# -> Float# -> JSString++foreign import javascript unsafe+ "h$jsstringDoubleToExponent($1,$2)"+ js_doubleToExponent :: Int# -> Double# -> JSString+foreign import javascript unsafe+ "h$jsstringDoubleToExponent($1,$2)"+ js_floatToExponent :: Int# -> Float# -> JSString+foreign import javascript unsafe+ "h$jsstringDoubleGeneric($1,$2)"+ js_doubleGeneric :: Int# -> Double# -> JSString+foreign import javascript unsafe+ "h$jsstringDoubleGeneric($1,$2)"+ js_floatGeneric :: Int# -> Float# -> JSString+
+ Data/JSString/RegExp.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MagicHash #-}++module Data.JSString.RegExp ( RegExp+ , pattern+ , isMultiline+ , isIgnoreCase+ , Match(..)+ , REFlags(..)+ , create+ , test+ , exec+ , execNext+ ) where++import GHCJS.Prim+import GHC.Exts (Any, Int#, Int(..))++import Unsafe.Coerce (unsafeCoerce)++import Data.JSString+import Data.Typeable++newtype RegExp = RegExp JSVal deriving Typeable++data REFlags = REFlags { multiline :: !Bool+ , ignoreCase :: !Bool+ }++data Match = Match { matched :: !JSString -- ^ the matched string+ , subMatched :: [JSString] -- ^ the matched parentesized substrings+ , matchRawIndex :: !Int -- ^ the raw index of the match in the string+ , matchInput :: !JSString -- ^ the input string+ }++create :: REFlags -> JSString -> RegExp+create flags pat = js_createRE pat flags'+ where+ flags' | multiline flags = if ignoreCase flags then "mi" else "m"+ | otherwise = if ignoreCase flags then "i" else ""+{-# INLINE create #-}++pattern :: RegExp -> JSString+pattern re = js_pattern re++isMultiline :: RegExp -> Bool+isMultiline re = js_isMultiline re++isIgnoreCase :: RegExp -> Bool+isIgnoreCase re = js_isIgnoreCase re++test :: JSString -> RegExp -> Bool+test x re = js_test x re+{-# INLINE test #-}++exec :: JSString -> RegExp -> Maybe Match+exec x re = exec' 0# x re+{-# INLINE exec #-}++execNext :: Match -> RegExp -> Maybe Match+execNext m re = case matchRawIndex m of+ I# i -> exec' i (matchInput m) re+{-# INLINE execNext #-}++exec' :: Int# -> JSString -> RegExp -> Maybe Match+exec' i x re = case js_exec i x re of+ (# -1#, _, _ #) -> Nothing+ (# i', y, z #) -> Just (Match y (unsafeCoerce z) (I# i) x)+{-# INLINE exec' #-}++matches :: JSString -> RegExp -> [Match]+matches x r = maybe [] go (exec x r)+ where+ go m = m : maybe [] go (execNext m r)+{-# INLINE matches #-}++replace :: RegExp -> JSString -> JSString -> JSString+replace x r = error "Data.JSString.RegExp.replace not implemented"+{-# INLINE replace #-}++split :: JSString -> RegExp -> [JSString]+split x r = unsafeCoerce (js_split -1# x r)+{-# INLINE split #-}++splitN :: Int -> JSString -> RegExp -> [JSString]+splitN (I# k) x r = unsafeCoerce (js_split k x r)+{-# INLINE splitN #-}++-- ----------------------------------------------------------------------------++foreign import javascript unsafe+ "new RegExp($1,$2)" js_createRE :: JSString -> JSString -> RegExp+foreign import javascript unsafe+ "$2.test($1)" js_test :: JSString -> RegExp -> Bool+foreign import javascript unsafe+ "h$jsstringExecRE" js_exec+ :: Int# -> JSString -> RegExp -> (# Int#, JSString, Any {- [JSString] -} #)+foreign import javascript unsafe+ "h$jsstringReplaceRE" js_replace :: RegExp -> JSString -> JSString -> JSString+foreign import javascript unsafe+ "h$jsstringSplitRE" js_split :: Int# -> JSString -> RegExp -> Any -- [JSString]+foreign import javascript unsafe+ "$1.multiline" js_isMultiline :: RegExp -> Bool+foreign import javascript unsafe+ "$1.ignoreCase" js_isIgnoreCase :: RegExp -> Bool+foreign import javascript unsafe+ "$1.pattern" js_pattern :: RegExp -> JSString+
+ Data/JSString/Text.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, JavaScriptFFI,+ UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim,+ MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-}++{- | Conversion between 'Data.Text.Text' and 'Data.JSString.JSString'++ -}++module Data.JSString.Text+ ( textToJSString+ , textFromJSString+ , lazyTextToJSString+ , lazyTextFromJSString+ , textFromJSVal+ , lazyTextFromJSVal+ ) where++import GHCJS.Prim++import GHC.Exts (ByteArray#, Int(..), Int#, Any)++import Control.DeepSeq++import qualified Data.Text.Array as A+import qualified Data.Text as T+import qualified Data.Text.Internal as T+import qualified Data.Text.Lazy as TL++import Data.JSString.Internal.Type++import Unsafe.Coerce++textToJSString :: T.Text -> JSString+textToJSString (T.Text (A.Array ba) (I# offset) (I# length)) =+ js_toString ba offset length+{-# INLINE textToJSString #-}++textFromJSString :: JSString -> T.Text+textFromJSString j =+ case js_fromString j of+ (# _ , 0# #) -> T.empty+ (# ba, length #) -> T.Text (A.Array ba) 0 (I# length)+{-# INLINE textFromJSString #-}++lazyTextToJSString :: TL.Text -> JSString+lazyTextToJSString t = rnf t `seq` js_lazyTextToString (unsafeCoerce t)+{-# INLINE lazyTextToJSString #-}++lazyTextFromJSString :: JSString -> TL.Text+lazyTextFromJSString = TL.fromStrict . textFromJSString+{-# INLINE lazyTextFromJSString #-}++-- | returns the empty Text if not a string+textFromJSVal :: JSVal -> T.Text+textFromJSVal j = case js_fromString' j of+ (# _, 0# #) -> T.empty+ (# ba, length #) -> T.Text (A.Array ba) 0 (I# length)+{-# INLINE textFromJSVal #-}++-- | returns the empty Text if not a string+lazyTextFromJSVal :: JSVal -> TL.Text+lazyTextFromJSVal = TL.fromStrict . textFromJSVal+{-# INLINE lazyTextFromJSVal #-}++-- ----------------------------------------------------------------------------++foreign import javascript unsafe+ "h$textToString($1,$2,$3)"+ js_toString :: ByteArray# -> Int# -> Int# -> JSString+foreign import javascript unsafe+ "h$textFromString"+ js_fromString :: JSString -> (# ByteArray#, Int# #)+foreign import javascript unsafe+ "h$textFromString"+ js_fromString' :: JSVal -> (# ByteArray#, Int# #)+foreign import javascript unsafe+ "h$lazyTextToString"+ js_lazyTextToString :: Any -> JSString
+ GHCJS/Buffer.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes,+ MagicHash, PolyKinds, BangPatterns+ #-}+{-|+ GHCJS implements the ByteArray# primitive with a JavaScript object+ containing an ArrayBuffer and various TypedArray views. This module+ contains utilities for manipulating and converting the buffer as+ a JavaScript object.++ None of the properties of a Buffer object should be written to in foreign+ code. Changing the contents of a MutableBuffer in foreign code is allowed.+ -}++-- fixme alignment not done yet!+module GHCJS.Buffer+ ( Buffer+ , MutableBuffer+ , create+ , createFromArrayBuffer+ , thaw, freeze, clone+ -- * JavaScript properties+ , byteLength+ , getArrayBuffer+ , getUint8Array+ , getUint16Array+ , getInt32Array+ , getDataView+ , getFloat32Array+ , getFloat64Array+ -- * primitive+ , toByteArray, fromByteArray+ , toByteArrayPrim, fromByteArrayPrim+ , toMutableByteArray, fromMutableByteArray+ , toMutableByteArrayPrim, fromMutableByteArrayPrim+ -- * bytestring+ , toByteString, fromByteString+ -- * pointers+ , toPtr, unsafeToPtr+ ) where++import GHC.Exts (ByteArray#, MutableByteArray#, Addr#, Ptr(..), Any)++import GHCJS.Buffer.Types+import GHCJS.Prim+import GHCJS.Internal.Types++import Data.Int+import Data.Word+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Internal as BS+import Data.Primitive.ByteArray++import qualified JavaScript.TypedArray.Internal.Types as I+import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer)+import JavaScript.TypedArray.DataView.Internal (SomeDataView)+import qualified JavaScript.TypedArray.Internal as I++import GHC.ForeignPtr++create :: Int -> IO MutableBuffer+create n | n >= 0 = js_create n+ | otherwise = error "create: negative size"+{-# INLINE create #-}++createFromArrayBuffer :: SomeArrayBuffer any -> SomeBuffer any+createFromArrayBuffer buf = js_wrapBuffer buf+{-# INLINE createFromArrayBuffer #-}++getArrayBuffer :: SomeBuffer any -> SomeArrayBuffer any+getArrayBuffer buf = js_getArrayBuffer buf+{-# INLINE getArrayBuffer #-}++getInt32Array :: SomeBuffer any -> I.SomeInt32Array any+getInt32Array buf = js_getInt32Array buf+{-# INLINE getInt32Array #-}++getUint8Array :: SomeBuffer any -> I.SomeUint8Array any+getUint8Array buf = js_getUint8Array buf+{-# INLINE getUint8Array #-}++getUint16Array :: SomeBuffer any -> I.SomeUint16Array any+getUint16Array buf = js_getUint16Array buf+{-# INLINE getUint16Array #-}++getFloat32Array :: SomeBuffer any -> I.SomeFloat32Array any+getFloat32Array buf = js_getFloat32Array buf+{-# INLINE getFloat32Array #-}++getFloat64Array :: SomeBuffer any -> I.SomeFloat64Array any+getFloat64Array buf = js_getFloat64Array buf+{-# INLINE getFloat64Array #-}++getDataView :: SomeBuffer any -> SomeDataView any+getDataView buf = js_getDataView buf+{-# INLINE getDataView #-}++freeze :: MutableBuffer -> IO Buffer+freeze x = js_clone x+{-# INLINE freeze #-}++thaw :: Buffer -> IO MutableBuffer+thaw buf = js_clone buf+{-# INLINE thaw #-}++clone :: MutableBuffer -> IO (SomeBuffer any2)+clone buf = js_clone buf+{-# INLINE clone #-}++fromByteArray :: ByteArray -> Buffer+fromByteArray (ByteArray ba) = fromByteArrayPrim ba+{-# INLINE fromByteArray #-}++toByteArray :: Buffer -> ByteArray+toByteArray buf = ByteArray (toByteArrayPrim buf)+{-# INLINE toByteArray #-}++fromMutableByteArray :: MutableByteArray s -> Buffer+fromMutableByteArray (MutableByteArray mba) = fromMutableByteArrayPrim mba+{-# INLINE fromMutableByteArray #-}++fromByteArrayPrim :: ByteArray# -> Buffer+fromByteArrayPrim ba = SomeBuffer (js_fromByteArray ba)+{-# INLINE fromByteArrayPrim #-}++toByteArrayPrim :: Buffer -> ByteArray#+toByteArrayPrim buf = js_toByteArray buf+{-# INLINE toByteArrayPrim #-}++fromMutableByteArrayPrim :: MutableByteArray# s -> Buffer+fromMutableByteArrayPrim mba = SomeBuffer (js_fromMutableByteArray mba)+{-# INLINE fromMutableByteArrayPrim #-}++toMutableByteArray :: Buffer -> MutableByteArray s+toMutableByteArray buf = MutableByteArray (toMutableByteArrayPrim buf)+{-# INLINE toMutableByteArray #-}++toMutableByteArrayPrim :: Buffer -> MutableByteArray# s+toMutableByteArrayPrim (SomeBuffer buf) = js_toMutableByteArray buf+{-# INLINE toMutableByteArrayPrim #-}++-- | Convert a 'ByteString' into a triple of (buffer, offset, length)+-- Warning: if the 'ByteString''s internal 'ForeignPtr' has a+-- finalizer associated with it, the returned 'Buffer' will not count+-- as a reference for the purpose of determining when that finalizer+-- should run.+fromByteString :: ByteString -> (Buffer, Int, Int)+fromByteString (BS.PS fp off len) =+ -- not super happy with this. What if the bytestring's foreign ptr+ -- has a nontrivial finalizer attached to it? I don't think there's+ -- a way to do that without someone else messing with the PS constructor+ -- directly though.+ let !(Ptr addr) = unsafeForeignPtrToPtr fp+ in (js_fromAddr addr, off, len)+{-# INLINE fromByteString #-}++-- | Wrap a 'Buffer' into a 'ByteString' using the given offset+-- and length.+toByteString :: Int -> Maybe Int -> Buffer -> ByteString+toByteString off _ buf+ | off < 0 = error "toByteString: negative offset"+ | off > byteLength buf = error "toByteString: offset past end of buffer"+toByteString off (Just len) buf+ | len < 0 = error "toByteString: negative length"+ | len > byteLength buf - off = error "toByteString: length past end of buffer"+ | otherwise = unsafeToByteString off len buf+toByteString off Nothing buf = unsafeToByteString off (byteLength buf - off) buf++unsafeToByteString :: Int -> Int -> Buffer -> ByteString+unsafeToByteString off len buf@(SomeBuffer bufRef) =+ let fp = ForeignPtr (js_toAddr buf) (PlainPtr (js_toMutableByteArray bufRef))+ in BS.PS fp off len++toPtr :: MutableBuffer -> Ptr a+toPtr buf = Ptr (js_toAddr buf)+{-# INLINE toPtr #-}++unsafeToPtr :: Buffer -> Ptr a+unsafeToPtr buf = Ptr (js_toAddr buf)+{-# INLINE unsafeToPtr #-}++byteLength :: SomeBuffer any -> Int+byteLength buf = js_byteLength buf+{-# INLINE byteLength #-}++-- ----------------------------------------------------------------------------++foreign import javascript unsafe+ "h$newByteArray" js_create :: Int -> IO MutableBuffer+foreign import javascript unsafe+ "h$wrapBuffer" js_wrapBuffer :: SomeArrayBuffer any -> SomeBuffer any+foreign import javascript unsafe+ "h$wrapBuffer($1.buf.slice($1.u8.byteOffset, $1.len))"+ js_clone :: SomeBuffer any1 -> IO (SomeBuffer any2)+foreign import javascript unsafe+ "$1.len" js_byteLength :: SomeBuffer any -> Int+foreign import javascript unsafe+ "$1.buf" js_getArrayBuffer :: SomeBuffer any -> SomeArrayBuffer any+foreign import javascript unsafe+ "$1.i3" js_getInt32Array :: SomeBuffer any -> I.SomeInt32Array any+foreign import javascript unsafe+ "$1.u8" js_getUint8Array :: SomeBuffer any -> I.SomeUint8Array any+foreign import javascript unsafe+ "$1.u1" js_getUint16Array :: SomeBuffer any -> I.SomeUint16Array any+foreign import javascript unsafe+ "$1.f3" js_getFloat32Array :: SomeBuffer any -> I.SomeFloat32Array any+foreign import javascript unsafe+ "$1.f6" js_getFloat64Array :: SomeBuffer any -> I.SomeFloat64Array any+foreign import javascript unsafe+ "$1.dv" js_getDataView :: SomeBuffer any -> SomeDataView any++-- ----------------------------------------------------------------------------+-- these things have the same representation (modulo boxing),+-- conversion is free++foreign import javascript unsafe + "$r = $1;" js_toByteArray :: SomeBuffer any -> ByteArray#+foreign import javascript unsafe + "$r = $1;" js_fromByteArray :: ByteArray# -> JSVal+foreign import javascript unsafe+ "$r = $1;" js_fromMutableByteArray :: MutableByteArray# s -> JSVal+foreign import javascript unsafe+ "$r = $1;" js_toMutableByteArray :: JSVal -> MutableByteArray# s+foreign import javascript unsafe+ "$r1 = $1; $r2 = 0;" js_toAddr :: SomeBuffer any -> Addr#+foreign import javascript unsafe+ "$r = $1;" js_fromAddr :: Addr# -> SomeBuffer any
+ GHCJS/Buffer/Types.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}++module GHCJS.Buffer.Types where++import GHCJS.Types+import GHCJS.Internal.Types++newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer JSVal++type Buffer = SomeBuffer Immutable+type MutableBuffer = SomeBuffer Mutable
+ GHCJS/Concurrent.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI,+ UnliftedFFITypes, DeriveDataTypeable, MagicHash+ #-}++{- | GHCJS has two types of threads. Regular, asynchronous threads are+ started with `h$run`, are managed by the scheduler and run in the+ background. `h$run` returns immediately.++ Synchronous threads are started with `h$runSync`, which returns+ when the thread has run to completion. When a synchronous thread+ does an operation that would block, like accessing an MVar or+ an asynchronous FFI call, it cannot continue synchronously.++ There are two ways this can be resolved, depending on the+ second argument of the `h$runSync` call:++ * The action is aborted and the thread receives a 'WouldBlockException'+ * The thread continues asynchronously, `h$runSync` returns++ Note: when a synchronous thread encounters a black hole from+ another thread, it tries to steal the work from that thread+ to avoid blocking. In some cases that might not be possible,+ for example when the data accessed is produced by a lazy IO+ operation. This is resolved the same way as blocking on an IO+ action would be.+ -}++module GHCJS.Concurrent ( isThreadSynchronous+ , isThreadContinueAsync+ , OnBlocked(..)+ , WouldBlockException(..)+ , withoutPreemption+ , synchronously+ ) where++import GHCJS.Prim++import Control.Applicative+import Control.Concurrent+import qualified Control.Exception as Ex++import GHC.Exts (ThreadId#)+import GHC.Conc.Sync (ThreadId(..))++import Data.Bits (testBit)+import Data.Data+import Data.Typeable++import Unsafe.Coerce++{- |+ The runtime tries to run synchronous threads to completion. Sometimes it's+ not possible to continue running a thread, for example when the thread+ tries to take an empty 'MVar'. The runtime can then either throw a+ 'WouldBlockException', aborting the blocking action, or continue the+ thread asynchronously.+ -}++data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked+ | ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked+ deriving (Data, Typeable, Enum, Show, Eq, Ord)++{- |+ Run the action without the scheduler preempting the thread. When a blocking+ action is encountered, the thread is still suspended and will continue+ without preemption when it's woken up again.++ When the thread encounters a black hole from another thread, the scheduler+ will attempt to clear it by temporarily switching to that thread.+ -}++withoutPreemption :: IO a -> IO a+withoutPreemption x = Ex.mask $ \restore -> do+ oldS <- js_setNoPreemption True+ if oldS+ then restore x+ else restore x `Ex.finally` js_setNoPreemption False+{-# INLINE withoutPreemption #-}+++{- |+ Run the action synchronously, which means that the thread will not+ be preempted by the scheduler. If the thread encounters a blocking+ operation, the runtime throws a WouldBlock exception.++ When the thread encounters a black hole from another thread, the scheduler+ will attempt to clear it by temporarily switching to that thread.+ -}+synchronously :: IO a -> IO a+synchronously x = Ex.mask $ \restore -> do+ oldS <- js_setSynchronous True+ if oldS+ then restore x+ else restore x `Ex.finally` js_setSynchronous False+{-# INLINE synchronously #-}++{- | Returns whether the 'ThreadId' is a synchronous thread+ -}+isThreadSynchronous :: ThreadId -> IO Bool+isThreadSynchronous = fmap (`testBit` 0) . syncThreadState++{- |+ Returns whether the 'ThreadId' will continue running async. Always+ returns 'True' when the thread is not synchronous.+ -}+isThreadContinueAsync :: ThreadId -> IO Bool+isThreadContinueAsync = fmap (`testBit` 1) . syncThreadState++{- |+ Returns whether the 'ThreadId' is not preemptible. Always+ returns 'True' when the thread is synchronous.+ -}+isThreadNonPreemptible :: ThreadId -> IO Bool+isThreadNonPreemptible = fmap (`testBit` 2) . syncThreadState++syncThreadState :: ThreadId-> IO Int+syncThreadState (ThreadId tid) = js_syncThreadState tid++-- ----------------------------------------------------------------------------++foreign import javascript unsafe "h$syncThreadState($1)"+ js_syncThreadState :: ThreadId# -> IO Int++foreign import javascript unsafe+ "$r = h$currentThread.noPreemption;\+ \h$currentThread.noPreemption = $1;"+ js_setNoPreemption :: Bool -> IO Bool;++foreign import javascript unsafe+ "$r = h$currentThread.isSynchronous;\+ \h$currentThread.isSynchronous = $1;"+ js_setSynchronous :: Bool -> IO Bool
+ GHCJS/Foreign.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-}+{- | Basic interop between Haskell and JavaScript.++ The principal type here is 'JSVal', which is a lifted type that contains+ a JavaScript reference. The 'JSVal' type is parameterized with one phantom+ type, and GHCJS.Types defines several type synonyms for specific variants.++ The code in this module makes no assumptions about 'JSVal a' types.+ Operations that can result in a JS exception that can kill a Haskell thread+ are marked unsafe (for example if the 'JSVal' contains a null or undefined+ value). There are safe variants where the JS exception is propagated as+ a Haskell exception, so that it can be handled on the Haskell side.++ For more specific types, like 'JSArray' or 'JSBool', the code assumes that+ the contents of the 'JSVal' actually is a JavaScript array or bool value.+ If it contains an unexpected value, the code can result in exceptions that+ kill the Haskell thread, even for functions not marked unsafe.++ The code makes use of `foreign import javascript', enabled with the+ `JavaScriptFFI` extension, available since GHC 7.8. There are three different+ safety levels:++ * unsafe: The imported code is run directly. returning an incorrectly typed+ value leads to undefined behaviour. JavaScript exceptions in the foreign+ code kill the Haskell thread.+ * safe: Returned values are replaced with a default value if they have+ the wrong type. JavaScript exceptions are caught and propagated as+ Haskell exceptions ('JSException'), so they can be handled with the+ standard "Control.Exception" machinery.+ * interruptible: The import is asynchronous. The calling Haskell thread+ sleeps until the foreign code calls the `$c` JavaScript function with+ the result. The thread is in interruptible state while blocked, so it+ can receive asynchronous exceptions.++ Unlike the FFI for native code, it's safe to call back into Haskell+ (`h$run`, `h$runSync`) from foreign code in any of the safety levels.+ Since JavaScript is single threaded, no Haskell threads can run while+ the foreign code is running.+ -}++module GHCJS.Foreign ( jsTrue+ , jsFalse+ , jsNull+ , toJSBool+ , fromJSBool+ , jsUndefined+ , isTruthy+ , isNull+ , isUndefined+ , isObject+ , isFunction+ , isString+ , isBoolean+ , isSymbol+ , isNumber+{- + , toArray+ , newArray+ , fromArray+ , pushArray+ , indexArray+ , lengthArray+ , newObj+ , getProp, unsafeGetProp+ , getPropMaybe, unsafeGetPropMaybe+ , setProp, unsafeSetProp+ , listProps -}+ , jsTypeOf, JSType(..)+ , jsonTypeOf, JSONType(..)+{- , wrapBuffer, wrapMutableBuffer+ , byteArrayJSVal, mutableByteArrayJSVal+ , bufferByteString, byteArrayByteString+ , unsafeMutableByteArrayByteString -}+ ) where++import GHCJS.Types+import GHCJS.Foreign.Internal+{-+import GHCJS.Marshal+import GHCJS.Marshal.Pure+-}+import Data.String (IsString(..))+import qualified Data.Text as T+++class ToJSString a where+ toJSString :: a -> JSString++-- toJSString = ptoJSVal+++class FromJSString a where+ fromJSString :: JSString -> a++-- default PFromJSVal+-- fromJSString = pfromJSVal+-- {-# INLINE fromJSString #-}+{-+instance ToJSString [Char]+instance FromJSString [Char]+instance ToJSString T.Text+instance FromJSString T.Text+instance ToJSString JSString+instance FromJSString JSString+-}+-- instance IsString JSString where+-- fromString = toJSString+-- {-# INLINE fromString #-}+-- -+{-+{- | Read a property from a JS object. Throws a 'JSException' if+ o is not a JS object or the property cannot be accessed+ -}+getProp :: ToJSString a => a -- ^ the property name+ -> JSVal b -- ^ the object+ -> IO (JSVal c) -- ^ the property value+getProp p o = js_getProp (toJSString p) o+{-# INLINE getProp #-}++{- | Read a property from a JS object. Kills the Haskell thread+ if o is not a JS object or the property cannot be accessed+ -}+unsafeGetProp :: ToJSString a => a -- ^ the property name+ -> JSVal b -- ^ the object+ -> IO (JSVal c) -- ^ the property value, Nothing if the object doesn't have a property with the given name+unsafeGetProp p o = js_unsafeGetProp (toJSString p) o+{-# INLINE unsafeGetProp #-}++{- | Read a property from a JS object. Throws a JSException if+ o is not a JS object or the property cannot be accessed+ -}+getPropMaybe :: ToJSString a => a -- ^ the property name+ -> JSVal b -- ^ the object+ -> IO (Maybe (JSVal c)) -- ^ the property value, Nothing if the object doesn't have a property with the given name+getPropMaybe p o = do+ p' <- js_getProp (toJSString p) o+ if isUndefined p' then return Nothing else return (Just p')+{-# INLINE getPropMaybe #-}++{- | Read a property from a JS object. Kills the Haskell thread+ if o is not a JS object or the property cannot be accessed+ -}+unsafeGetPropMaybe :: ToJSString a => a -- ^ the property name+ -> JSVal b -- ^ the object+ -> IO (Maybe (JSVal c)) -- ^ the property value, Nothing if the object doesn't have a property with the given name+unsafeGetPropMaybe p o = do+ p' <- js_unsafeGetProp (toJSString p) o+ if isUndefined p' then return Nothing else return (Just p')+{-# INLINE unsafeGetPropMaybe #-}++{- | set a property in a JS object. Throws a 'JSException' if+ o is not a reference to a JS object or the property cannot+ be set+ -}+setProp :: ToJSString a => a -- ^ the property name+ -> JSVal b -- ^ the value+ -> JSVal c -- ^ the object+ -> IO ()+setProp p v o = js_setProp (toJSString p) v o+{-# INLINE setProp #-}++{- | set a property in a JS object. Kills the Haskell thread+ if the property cannot be set.+-}+unsafeSetProp :: ToJSString a => a -- ^ the property name+ -> JSVal b -- ^ the value+ -> JSVal c -- ^ the object+ -> IO ()+unsafeSetProp p v o = js_unsafeSetProp (toJSString p) v o++-}
+ GHCJS/Foreign/Callback.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes,+ GHCForeignImportPrim, DeriveDataTypeable, GHCForeignImportPrim #-}+module GHCJS.Foreign.Callback+ ( Callback+ , OnBlocked(..)+ , releaseCallback+ -- * asynchronous callbacks+ , asyncCallback+ , asyncCallback1+ , asyncCallback2+ , asyncCallback3+ -- * synchronous callbacks+ , syncCallback+ , syncCallback1+ , syncCallback2+ , syncCallback3+ -- * synchronous callbacks that return a value+ , syncCallback'+ , syncCallback1'+ , syncCallback2'+ , syncCallback3'+ ) where++import GHCJS.Concurrent+import GHCJS.Marshal+import GHCJS.Marshal.Pure+import GHCJS.Foreign.Callback.Internal+import GHCJS.Prim+import GHCJS.Types++import qualified GHC.Exts as Exts++import Data.Typeable++import Unsafe.Coerce++{- |+ When you create a callback, the Haskell runtime stores a reference to+ the exported IO action or function. This means that all data referenced by the+ exported value stays in memory, even if nothing outside the Haskell runtime+ holds a reference to to callback.++ Use 'releaseCallback' to free the reference. Subsequent calls from JavaScript+ to the callback will result in an exception.+ -}+releaseCallback :: Callback a -> IO ()+releaseCallback x = js_release x++{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous+ thread when called.++ Call 'releaseCallback' when done with the callback, freeing memory referenced+ by the IO action.+ -}+syncCallback :: OnBlocked -- ^ what to do when the thread blocks+ -> IO () -- ^ the Haskell action+ -> IO (Callback (IO ())) -- ^ the callback+syncCallback onBlocked x = js_syncCallback (onBlocked == ContinueAsync) (unsafeCoerce x)+++{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous+ thread when called. The callback takes one argument that it passes as a JSVal value to+ the Haskell function.++ Call 'releaseCallback' when done with the callback, freeing data referenced+ by the function.+ -}+syncCallback1 :: OnBlocked -- ^ what to do when the thread blocks+ -> (JSVal -> IO ()) -- ^ the Haskell function+ -> IO (Callback (JSVal -> IO ())) -- ^ the callback+syncCallback1 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 1 (unsafeCoerce x)+++{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous+ thread when called. The callback takes two arguments that it passes as JSVal values to+ the Haskell function.++ Call 'releaseCallback' when done with the callback, freeing data referenced+ by the function.+ -}+syncCallback2 :: OnBlocked -- ^ what to do when the thread blocks+ -> (JSVal -> JSVal -> IO ()) -- ^ the Haskell function+ -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback+syncCallback2 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 2 (unsafeCoerce x)++{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous+ thread when called. The callback takes three arguments that it passes as JSVal values to+ the Haskell function.++ Call 'releaseCallback' when done with the callback, freeing data referenced+ by the function.+ -}+syncCallback3 :: OnBlocked -- ^ what to do when the thread blocks+ -> (JSVal -> JSVal -> JSVal -> IO ()) -- ^ the Haskell function+ -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback+syncCallback3 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 3 (unsafeCoerce x)++{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous+ thread when called.++ Call 'releaseCallback' when done with the callback, freeing memory referenced+ by the IO action.+ -}+syncCallback' :: IO JSVal+ -> IO (Callback (IO JSVal))+syncCallback' x = js_syncCallbackReturn (unsafeCoerce x)++syncCallback1' :: (JSVal -> IO JSVal)+ -> IO (Callback (JSVal -> IO JSVal))+syncCallback1' x = js_syncCallbackApplyReturn 1 (unsafeCoerce x)++syncCallback2' :: (JSVal -> JSVal -> IO JSVal)+ -> IO (Callback (JSVal -> JSVal -> IO JSVal))+syncCallback2' x = js_syncCallbackApplyReturn 2 (unsafeCoerce x)++syncCallback3' :: (JSVal -> JSVal -> JSVal -> IO JSVal)+ -> IO (Callback (JSVal -> JSVal -> JSVal -> IO JSVal))+syncCallback3' x = js_syncCallbackApplyReturn 3 (unsafeCoerce x)++{- | Make a callback (JavaScript function) that runs the supplied IO action in an asynchronous+ thread when called.++ Call 'releaseCallback' when done with the callback, freeing data referenced+ by the IO action.+ -}+asyncCallback :: IO () -- ^ the action that the callback runs+ -> IO (Callback (IO ())) -- ^ the callback+asyncCallback x = js_asyncCallback (unsafeCoerce x)++asyncCallback1 :: (JSVal -> IO ()) -- ^ the function that the callback calls+ -> IO (Callback (JSVal -> IO ())) -- ^ the calback+asyncCallback1 x = js_asyncCallbackApply 1 (unsafeCoerce x)++asyncCallback2 :: (JSVal -> JSVal -> IO ()) -- ^ the Haskell function that the callback calls+ -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback+asyncCallback2 x = js_asyncCallbackApply 2 (unsafeCoerce x)++asyncCallback3 :: (JSVal -> JSVal -> JSVal -> IO ()) -- ^ the Haskell function that the callback calls+ -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback+asyncCallback3 x = js_asyncCallbackApply 3 (unsafeCoerce x)++-- ----------------------------------------------------------------------------++foreign import javascript unsafe "h$makeCallback(h$runSync, [$1], $2)"+ js_syncCallback :: Bool -> Exts.Any -> IO (Callback (IO b))+foreign import javascript unsafe "h$makeCallback(h$run, [], $1)"+ js_asyncCallback :: Exts.Any -> IO (Callback (IO b))+foreign import javascript unsafe "h$makeCallback(h$runSyncReturn, [false], $1)"+ js_syncCallbackReturn :: Exts.Any -> IO (Callback (IO JSVal))++foreign import javascript unsafe "h$makeCallbackApply($2, h$runSync, [$1], $3)"+ js_syncCallbackApply :: Bool -> Int -> Exts.Any -> IO (Callback b)+foreign import javascript unsafe "h$makeCallbackApply($1, h$run, [], $2)"+ js_asyncCallbackApply :: Int -> Exts.Any -> IO (Callback b)+foreign import javascript unsafe+ "h$makeCallbackApply($1, h$runSyncReturn, [false], $2)"+ js_syncCallbackApplyReturn :: Int -> Exts.Any -> IO (Callback b)++foreign import javascript unsafe "h$release"+ js_release :: Callback a -> IO ()+
+ GHCJS/Foreign/Callback/Internal.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveDataTypeable #-}++module GHCJS.Foreign.Callback.Internal where++import GHCJS.Types+import GHCJS.Marshal.Internal++import Data.Typeable++newtype Callback a = Callback JSVal deriving Typeable+instance IsJSVal (Callback a)+
+ GHCJS/Foreign/Export.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE EmptyDataDecls #-}++{- | + Dynamically export Haskell values to JavaScript+ -}++module GHCJS.Foreign.Export+ ( Export+ , export+ , withExport+ , derefExport+ , releaseExport+ ) where++import Control.Exception (bracket)+import GHC.Exts (Any)+import GHC.Fingerprint+import Data.Typeable+import Data.Word+import Unsafe.Coerce+import qualified GHC.Exts as Exts++import GHCJS.Prim+import GHCJS.Types++newtype Export a = Export JSVal+instance IsJSVal (Export a)++{- |+ Export any Haskell value to a JavaScript reference without evaluating it.+ The JavaScript reference can be passed to foreign code and used to retrieve+ the value later.++ The data referenced by the value will be kept in memory until you call+ 'releaseExport', even if no foreign code references the export anymore.+ -}+export :: Typeable a => a -> IO (Export a)+export x = js_export w1 w2 (unsafeCoerce x)+ where+ Fingerprint w1 w2 = typeRepFingerprint (typeOf x)++{- |+ Export the value and run the action. The value is only exported for the+ duration of the action. Dereferencing it after the 'withExport' call+ has returned will always return 'Nothing'.+ -}+-- fixme is this safe with nested exports?+withExport :: Typeable a => a -> (Export a -> IO b) -> IO b+withExport x m = bracket (export x) releaseExport m++{- |+ Retrieve the Haskell value from an export. Returns 'Nothing' if the+ type does not match or the export has already been released.+ -}++derefExport :: forall a. Typeable a => Export a -> IO (Maybe a)+derefExport e = do+ let Fingerprint w1 w2 = typeRepFingerprint (typeOf (undefined :: a))+ r <- js_derefExport w1 w2 e+ if isNull r+ then return Nothing+ else Just . unsafeCoerce <$> js_toHeapObject r++{- |+ Release all memory associated with the export. Subsequent calls to+ 'derefExport' will return 'Nothing'+ -}+releaseExport :: Export a -> IO ()+releaseExport e = js_releaseExport e++-- ----------------------------------------------------------------------------++foreign import javascript unsafe+ "h$exportValue"+ js_export :: Word64 -> Word64 -> Any -> IO (Export a)+foreign import javascript unsafe+ "h$derefExport"+ js_derefExport :: Word64 -> Word64 -> Export a -> IO JSVal+foreign import javascript unsafe+ "$r = $1;" js_toHeapObject :: JSVal -> IO Any+foreign import javascript unsafe+ "h$releaseExport"+ js_releaseExport :: Export a -> IO ()
+ GHCJS/Foreign/Internal.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, JavaScriptFFI,+ UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim,+ MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-}++{- | Basic interop between Haskell and JavaScript.++ The principal type here is 'JSVal', which is a lifted type that contains+ a JavaScript reference. The 'JSVal' type is parameterized with one phantom+ type, and GHCJS.Types defines several type synonyms for specific variants.++ The code in this module makes no assumptions about 'JSVal a' types.+ Operations that can result in a JS exception that can kill a Haskell thread+ are marked unsafe (for example if the 'JSVal' contains a null or undefined+ value). There are safe variants where the JS exception is propagated as+ a Haskell exception, so that it can be handled on the Haskell side.++ For more specific types, like 'JSArray' or 'JSBool', the code assumes that+ the contents of the 'JSVal' actually is a JavaScript array or bool value.+ If it contains an unexpected value, the code can result in exceptions that+ kill the Haskell thread, even for functions not marked unsafe.++ The code makes use of `foreign import javascript', enabled with the+ `JavaScriptFFI` extension, available since GHC 7.8. There are three different+ safety levels:++ * unsafe: The imported code is run directly. returning an incorrectly typed+ value leads to undefined behaviour. JavaScript exceptions in the foreign+ code kill the Haskell thread.+ * safe: Returned values are replaced with a default value if they have+ the wrong type. JavaScript exceptions are caught and propagated as+ Haskell exceptions ('JSException'), so they can be handled with the+ standard "Control.Exception" machinery.+ * interruptible: The import is asynchronous. The calling Haskell thread+ sleeps until the foreign code calls the `$c` JavaScript function with+ the result. The thread is in interruptible state while blocked, so it+ can receive asynchronous exceptions.++ Unlike the FFI for native code, it's safe to call back into Haskell+ (`h$run`, `h$runSync`) from foreign code in any of the safety levels.+ Since JavaScript is single threaded, no Haskell threads can run while+ the foreign code is running.+ -}++module GHCJS.Foreign.Internal ( JSType(..)+ , jsTypeOf+ , JSONType(..)+ , jsonTypeOf+ -- , mvarRef+ , isTruthy+ , fromJSBool+ , toJSBool+ , jsTrue+ , jsFalse+ , jsNull+ , jsUndefined+ , isNull+ -- type predicates+ , isUndefined+ , isNumber+ , isObject+ , isBoolean+ , isString+ , isSymbol+ , isFunction+ -- internal use, fixme remove+{- , toArray+ , newArray+ , fromArray+ , pushArray+ , indexArray+ , lengthArray -}+-- , newObj+-- , js_getProp, js_unsafeGetProp+-- , js_setProp, js_unsafeSetProp+-- , listProps+{- , wrapBuffer, wrapMutableBuffer+ , byteArrayJSVal, mutableByteArrayJSVal+ , bufferByteString, byteArrayByteString+ , unsafeMutableByteArrayByteString -}+ ) where++import GHCJS.Types+import qualified GHCJS.Prim as Prim++import GHC.Prim+import GHC.Exts++import Control.Applicative+import Control.Concurrent.MVar+import Control.DeepSeq (force)+import Control.Exception (evaluate, Exception)++import Foreign.ForeignPtr.Safe+import Foreign.Ptr++import Data.Primitive.Addr (Addr(..))+import Data.Primitive.ByteArray+import Data.Typeable (Typeable)++import Data.ByteString (ByteString)+import Data.ByteString.Unsafe (unsafePackAddressLen)++import qualified Data.Text.Array as A+import qualified Data.Text as T+import qualified Data.Text.Internal as T+import qualified Data.Text.Lazy as TL (Text, toStrict, fromStrict)++import Unsafe.Coerce++-- types returned by JS typeof operator+data JSType = Undefined+ | Object+ | Boolean+ | Number+ | String+ | Symbol+ | Function+ | Other -- ^ implementation dependent+ deriving (Show, Eq, Ord, Enum, Typeable)++-- JSON value type+data JSONType = JSONNull+ | JSONInteger+ | JSONFloat+ | JSONBool+ | JSONString+ | JSONArray+ | JSONObject+ deriving (Show, Eq, Ord, Enum, Typeable)++fromJSBool :: JSVal -> Bool+fromJSBool b = js_fromBool b+{-# INLINE fromJSBool #-}++toJSBool :: Bool -> JSVal+toJSBool True = jsTrue+toJSBool _ = jsFalse+{-# INLINE toJSBool #-}++jsTrue :: JSVal+jsTrue = mkRef (js_true 0#)+{-# INLINE jsTrue #-}++jsFalse :: JSVal+jsFalse = mkRef (js_false 0#)+{-# INLINE jsFalse #-}++jsNull :: JSVal+jsNull = mkRef (js_null 0#)+{-# INLINE jsNull #-}++jsUndefined :: JSVal+jsUndefined = mkRef (js_undefined 0#)+{-# INLINE jsUndefined #-}++-- check whether a reference is `truthy' in the JavaScript sense+isTruthy :: JSVal -> Bool+isTruthy b = js_isTruthy b+{-# INLINE isTruthy #-}++-- isUndefined :: JSVal -> Bool+-- isUndefined o = js_isUndefined o+-- {-# INLINE isUndefined #-}++-- isNull :: JSVal -> Bool+-- isNull o = js_isNull o+-- {-# INLINE isNull #-}++isObject :: JSVal -> Bool+isObject o = js_isObject o+{-# INLINE isObject #-}++isNumber :: JSVal -> Bool+isNumber o = js_isNumber o+{-# INLINE isNumber #-}++isString :: JSVal -> Bool+isString o = js_isString o+{-# INLINE isString #-}++isBoolean :: JSVal -> Bool+isBoolean o = js_isBoolean o+{-# INLINE isBoolean #-}++isFunction :: JSVal -> Bool+isFunction o = js_isFunction o+{-# INLINE isFunction #-}++isSymbol :: JSVal -> Bool+isSymbol o = js_isSymbol o+{-# INLINE isSymbol #-}+++{-+-- something that we can unsafeCoerce Text from+data Text' = Text'+ {-# UNPACK #-} !Array' -- payload+ {-# UNPACK #-} !Int -- offset+ {-# UNPACK #-} !Int -- length++data Array' = Array' {+ aBA :: ByteArray#+ }++data Text'' = Text''+ {-# UNPACK #-} !Array'' -- payload+ {-# UNPACK #-} !Int -- offset+ {-# UNPACK #-} !Int -- length++data Array'' = Array'' {+ aRef :: Ref#+ }++-- same rep as Ptr Addr#, use this to get just the first field out+data Ptr' a = Ptr' ByteArray# Int#++ptrToPtr' :: Ptr a -> Ptr' b+ptrToPtr' = unsafeCoerce++ptr'ToPtr :: Ptr' a -> Ptr b+ptr'ToPtr = unsafeCoerce+-}+{-+toArray :: [JSVal a] -> IO (JSArray a)+toArray xs = Prim.toJSArray xs+{-# INLINE toArray #-}++pushArray :: JSVal a -> JSArray a -> IO ()+pushArray r arr = js_push r arr+{-# INLINE pushArray #-}++fromArray :: JSArray (JSVal a) -> IO [JSVal a]+fromArray a = Prim.fromJSArray a+{-# INLINE fromArray #-}++lengthArray :: JSArray a -> IO Int+lengthArray a = js_length a+{-# INLINE lengthArray #-}++indexArray :: Int -> JSArray a -> IO (JSVal a)+indexArray = js_index+{-# INLINE indexArray #-}++unsafeIndexArray :: Int -> JSArray a -> IO (JSVal a)+unsafeIndexArray = js_unsafeIndex+{-# INLINE unsafeIndexArray #-}++newArray :: IO (JSArray a)+newArray = js_emptyArray+{-# INLINE newArray #-}++newObj :: IO (JSVal a)+newObj = js_emptyObj+{-# INLINE newObj #-}++listProps :: JSVal a -> IO [JSString]+listProps o = fmap unsafeCoerce . Prim.fromJSArray =<< js_listProps o+{-# INLINE listProps #-}+-}+jsTypeOf :: JSVal -> JSType+jsTypeOf r = tagToEnum# (js_jsTypeOf r)+{-# INLINE jsTypeOf #-}++jsonTypeOf :: JSVal -> JSONType+jsonTypeOf r = tagToEnum# (js_jsonTypeOf r)+{-# INLINE jsonTypeOf #-}++{-+{- | Convert a JavaScript ArrayBuffer to a 'ByteArray' without copying. Throws+ a 'JSException' if the 'JSVal' is not an ArrayBuffer.+ -}+wrapBuffer :: Int -- ^ offset from the start in bytes, if this is not a multiple of 8,+ -- not all types can be read from the ByteArray#+ -> Int -- ^ length in bytes (use zero or a negative number to use the whole ArrayBuffer)+ -> JSVal a -- ^ JavaScript ArrayBuffer object+ -> IO ByteArray -- ^ result+wrapBuffer offset size buf = unsafeCoerce <$> js_wrapBuffer offset size buf+{-# INLINE wrapBuffer #-}++{- | Convert a JavaScript ArrayBuffer to a 'MutableByteArray' without copying. Throws+ a 'JSException' if the 'JSVal' is not an ArrayBuffer.+ -}+wrapMutableBuffer :: Int -- ^ offset from the start in bytes, if this is not a multiple of 8,+ -- not all types can be read from / written to the ByteArray#+ -> Int -- ^ the length in bytes (use zero or a negative number to use the whole ArrayBuffer)+ -> JSVal a -- ^ JavaScript ArrayBuffer object+ -> IO (MutableByteArray s)+wrapMutableBuffer offset size buf = unsafeCoerce <$> js_wrapBuffer offset size buf+{-# INLINE wrapMutableBuffer #-}++{- | Get the underlying JS object from a 'ByteArray#'. The object o+ contains an ArrayBuffer (o.buf) and several typed array views on it (which+ can have an offset from the start of the buffer and/or a reduced length):+ * o.i3 : 32 bit signed+ * o.u8 : 8 bit unsigned+ * o.u1 : 16 bit unsigned+ * o.f3 : 32 bit single precision float+ * o.f6 : 64 bit double precision float+ * o.dv : a DataView+ Some of the views will be null if the offset is not a multiple of 8.+ -}+byteArrayJSVal :: ByteArray# -> JSVal a+byteArrayJSVal a = unsafeCoerce (ByteArray a)+{-# INLINE byteArrayJSVal #-}++{- | Get the underlying JS object from a 'MutableByteArray#'. The object o+ contains an ArrayBuffer (o.buf) and several typed array views on it (which+ can have an offset from the start of the buffer and/or a reduced length):+ * o.i3 : 32 bit signed+ * o.u8 : 8 bit unsigned+ * o.u1 : 16 bit unsigned+ * o.f3 : 32 bit single precision float+ * o.f6 : 64 bit double precision float+ * o.dv : a DataView+ Some of the views will be null if the offset is not a multiple of 8.+ -}+mutableByteArrayJSVal :: MutableByteArray# s -> JSVal a+mutableByteArrayJSVal a = unsafeCoerce (MutableByteArray a)+{-# INLINE mutableByteArrayJSVal #-}++foreign import javascript safe "h$wrapBuffer($3, true, $1, $2)"+ js_wrapBuffer :: Int -> Int -> JSVal a -> IO (JSVal ())++{- | Convert an ArrayBuffer to a strict 'ByteString'+ this wraps the original buffer, without copying.+ Use 'byteArrayByteString' if you already have a wrapped buffer+ -}+bufferByteString :: Int -- ^ offset from the start in bytes+ -> Int -- ^ length in bytes (use zero or a negative number to get the whole ArrayBuffer)+ -> JSVal a+ -> IO ByteString+bufferByteString offset length buf = do+ (ByteArray ba) <- wrapBuffer offset length buf+ byteArrayByteString ba++{- | Pack a ByteArray# primitive into a ByteString+ without copying the buffer.++ This is unsafe in native code+ -}+byteArrayByteString :: ByteArray#+ -> IO ByteString+byteArrayByteString arr =+#ifdef ghcjs_HOST_OS+ let ba = ByteArray arr+ !(Addr a) = byteArrayContents ba+ in unsafePackAddressLen (sizeofByteArray ba) a+#else+ error "GHCJS.Foreign.byteArrayToByteString: not JS"+#endif++{- | Pack a MutableByteArray# primitive into a 'ByteString' without+ copying. The byte array shouldn't be modified after converting.++ This is unsafe in native code+ -}+unsafeMutableByteArrayByteString :: MutableByteArray# s+ -> IO ByteString+unsafeMutableByteArrayByteString arr =+#ifdef ghcjs_HOST_OS+ let ba = MutableByteArray arr+ !(Addr a) = mutableByteArrayContents ba+ in unsafePackAddressLen (sizeofMutableByteArray ba) a+#else+ error "GHCJS.Foreign.unsafeMutableByteArrayToByteString: no JS"+#endif+-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$r = $1===true;"+ js_fromBool :: JSVal -> Bool+foreign import javascript unsafe+ "$1 ? true : false"+ js_isTruthy :: JSVal -> Bool+foreign import javascript unsafe "$r = true;" js_true :: Int# -> Ref#+foreign import javascript unsafe "$r = false;" js_false :: Int# -> Ref#+foreign import javascript unsafe "$r = null;" js_null :: Int# -> Ref#+foreign import javascript unsafe "$r = undefined;" js_undefined :: Int# -> Ref#+-- foreign import javascript unsafe "$r = [];" js_emptyArray :: IO (JSArray a)+-- foreign import javascript unsafe "$r = {};" js_emptyObj :: IO (JSVal a)+--foreign import javascript unsafe "$3[$1] = $2;"+-- js_unsafeWriteArray :: Int# -> JSVal a -> JSArray b -> IO ()+-- foreign import javascript unsafe "h$fromArray"+-- js_fromArray :: JSArray a -> IO Ref# -- [a]+--foreign import javascript safe "$2.push($1)"+-- js_push :: JSVal a -> JSArray a -> IO ()+--foreign import javascript safe "$1.length" js_length :: JSArray a -> IO Int+--foreign import javascript safe "$2[$1]"+-- js_index :: Int -> JSArray a -> IO (JSVal a)+--foreign import javascript unsafe "$2[$1]"+-- js_unsafeIndex :: Int -> JSArray a -> IO (JSVal a)+foreign import javascript unsafe "$2[$1]"+ js_unsafeGetProp :: JSString -> JSVal -> IO JSVal+foreign import javascript unsafe "$3[$1] = $2"+ js_unsafeSetProp :: JSString -> JSVal -> JSVal -> IO ()+{-+foreign import javascript safe "h$listProps($1)"+ js_listProps :: JSVal a -> IO (JSArray JSString)+-}+foreign import javascript unsafe "h$jsTypeOf($1)"+ js_jsTypeOf :: JSVal -> Int#+foreign import javascript unsafe "h$jsonTypeOf($1)"+ js_jsonTypeOf :: JSVal -> Int#+-- foreign import javascript unsafe "h$listToArray"+-- js_toArray :: Any -> IO (JSArray a)+-- foreign import javascript unsafe "$1 === null"+-- js_isNull :: JSVal a -> Bool++-- foreign import javascript unsafe "h$isUndefined" js_isUndefined :: JSVal a -> Bool+foreign import javascript unsafe "h$isObject" js_isObject :: JSVal -> Bool+foreign import javascript unsafe "h$isBoolean" js_isBoolean :: JSVal -> Bool+foreign import javascript unsafe "h$isNumber" js_isNumber :: JSVal -> Bool+foreign import javascript unsafe "h$isString" js_isString :: JSVal -> Bool+foreign import javascript unsafe "h$isSymbol" js_isSymbol :: JSVal -> Bool+foreign import javascript unsafe "h$isFunction" js_isFunction :: JSVal -> Bool
+ GHCJS/Internal/Types.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module GHCJS.Internal.Types where++import Data.Coerce+import Unsafe.Coerce++import Control.DeepSeq++import GHCJS.Prim (JSVal)++instance NFData JSVal where+ rnf x = x `seq` ()++class IsJSVal a where+ jsval_ :: a -> JSVal++ default jsval_ :: Coercible a JSVal => a -> JSVal+ jsval_ = coerce+ {-# INLINE jsval_ #-}++jsval :: IsJSVal a => a -> JSVal+jsval = jsval_+{-# INLINE jsval #-}++data MutabilityType s = Mutable_ s+ | Immutable_ s+ | STMutable s++type Mutable = Mutable_ ()+type Immutable = Immutable_ ()++data IsItMutable = IsImmutable+ | IsMutable++type family Mutability (a :: MutabilityType s) :: IsItMutable where+ Mutability Immutable = IsImmutable+ Mutability Mutable = IsMutable+ Mutability (STMutable s) = IsMutable++
+ GHCJS/Marshal.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE DefaultSignatures,+ TypeOperators,+ ScopedTypeVariables,+ DefaultSignatures,+ FlexibleContexts,+ FlexibleInstances,+ OverloadedStrings,+ TupleSections,+ MagicHash,+ CPP,+ JavaScriptFFI,+ ForeignFunctionInterface,+ UnliftedFFITypes,+ BangPatterns+ #-}++module GHCJS.Marshal ( FromJSVal(..)+ , ToJSVal(..)+ , toJSVal_aeson+ , toJSVal_pure+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)++import qualified Data.Aeson as AE+import Data.Attoparsec.Number (Number(..))+import Data.Bits ((.&.))+import Data.Char (chr, ord)+import qualified Data.HashMap.Strict as H+import Data.Int (Int8, Int16, Int32)+import qualified Data.JSString as JSS+import qualified Data.JSString.Text as JSS+import Data.Maybe+import Data.Scientific (Scientific, scientific, fromFloatDigits)+import Data.Text (Text)+import qualified Data.Vector as V+import Data.Word (Word8, Word16, Word32, Word)+import Data.Primitive.ByteArray++import Unsafe.Coerce (unsafeCoerce)++import GHC.Int+import GHC.Word+import GHC.Types+import GHC.Float+import GHC.Prim+import GHC.Generics++import GHCJS.Types+import GHCJS.Foreign.Internal+import GHCJS.Marshal.Pure+++import qualified JavaScript.Array as A+import qualified JavaScript.Array.Internal as AI+import qualified JavaScript.Object as O+import qualified JavaScript.Object.Internal as OI++import GHCJS.Marshal.Internal++instance FromJSVal JSVal where+ fromJSValUnchecked x = return x+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = return . Just+ {-# INLINE fromJSVal #-}+instance FromJSVal () where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+-- {-# INLINE fromJSVal #-}+instance FromJSVal a => FromJSVal [a] where+ fromJSVal = fromJSValListOf+ {-# INLINE fromJSVal #-}+instance FromJSVal a => FromJSVal (Maybe a) where+ fromJSValUnchecked x | isUndefined x || isNull x = return Nothing+ | otherwise = fromJSVal x+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal x | isUndefined x || isNull x = return (Just Nothing)+ | otherwise = fmap (fmap Just) fromJSVal x+ {-# INLINE fromJSVal #-}+instance FromJSVal JSString where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Text where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Char where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+ fromJSValUncheckedListOf = fromJSValUnchecked_pure+ {-# INLINE fromJSValListOf #-}+ fromJSValListOf = fromJSVal_pure+ {-# INLINE fromJSValUncheckedListOf #-}+instance FromJSVal Bool where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Int where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Int8 where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Int16 where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Int32 where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Word where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Word8 where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Word16 where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Word32 where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Float where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal Double where+ fromJSValUnchecked = fromJSValUnchecked_pure+ {-# INLINE fromJSValUnchecked #-}+ fromJSVal = fromJSVal_pure+ {-# INLINE fromJSVal #-}+instance FromJSVal AE.Value where+ fromJSVal r = case jsonTypeOf r of+ JSONNull -> return (Just AE.Null)+ JSONInteger -> liftM (AE.Number . flip scientific 0 . (toInteger :: Int -> Integer))+ <$> fromJSVal r+ JSONFloat -> liftM (AE.Number . (fromFloatDigits :: Double -> Scientific))+ <$> fromJSVal r+ JSONBool -> liftM AE.Bool <$> fromJSVal r+ JSONString -> liftM AE.String <$> fromJSVal r+ JSONArray -> liftM (AE.Array . V.fromList) <$> fromJSVal r+ JSONObject -> do+ props <- OI.listProps (OI.Object r)+ runMaybeT $ do+ propVals <- forM props $ \p -> do+ v <- MaybeT (fromJSVal =<< OI.getProp p (OI.Object r))+ return (JSS.textFromJSString p, v)+ return (AE.Object (H.fromList propVals))+ {-# INLINE fromJSVal #-}+instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where+ fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1+ {-# INLINE fromJSVal #-}+instance (FromJSVal a, FromJSVal b, FromJSVal c) => FromJSVal (a,b,c) where+ fromJSVal r = runMaybeT $ (,,) <$> jf r 0 <*> jf r 1 <*> jf r 2+ {-# INLINE fromJSVal #-}+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d) => FromJSVal (a,b,c,d) where+ fromJSVal r = runMaybeT $ (,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3+ {-# INLINE fromJSVal #-}+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e) => FromJSVal (a,b,c,d,e) where+ fromJSVal r = runMaybeT $ (,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4+ {-# INLINE fromJSVal #-}+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f) => FromJSVal (a,b,c,d,e,f) where+ fromJSVal r = runMaybeT $ (,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5+ {-# INLINE fromJSVal #-}+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g) => FromJSVal (a,b,c,d,e,f,g) where+ fromJSVal r = runMaybeT $ (,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6+ {-# INLINE fromJSVal #-}+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g, FromJSVal h) => FromJSVal (a,b,c,d,e,f,g,h) where+ fromJSVal r = runMaybeT $ (,,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 <*> jf r 7+ {-# INLINE fromJSVal #-}++jf :: FromJSVal a => JSVal -> Int -> MaybeT IO a+jf r n = MaybeT $ do+ r' <- AI.read n (AI.SomeJSArray r)+ if isUndefined r+ then return Nothing+ else fromJSVal r'++instance ToJSVal JSVal where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal AE.Value where+ toJSVal = toJSVal_aeson+ {-# INLINE toJSVal #-}+instance ToJSVal JSString where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Text where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Char where+ toJSVal = return . pToJSVal+ {-# INLINE toJSVal #-}+ toJSValListOf = return . pToJSVal+ {-# INLINE toJSValListOf #-}+instance ToJSVal Bool where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Int where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Int8 where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Int16 where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Int32 where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Word where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Word8 where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Word16 where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Word32 where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Float where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal Double where+ toJSVal = toJSVal_pure+ {-# INLINE toJSVal #-}+instance ToJSVal a => ToJSVal [a] where+ toJSVal = toJSValListOf+ {-# INLINE toJSVal #-}+instance ToJSVal a => ToJSVal (Maybe a) where+ toJSVal Nothing = return jsNull+ toJSVal (Just a) = toJSVal a+ {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b) => ToJSVal (a,b) where+ toJSVal (a,b) = join $ arr2 <$> toJSVal a <*> toJSVal b+ {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c) => ToJSVal (a,b,c) where+ toJSVal (a,b,c) = join $ arr3 <$> toJSVal a <*> toJSVal b <*> toJSVal c+ {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d) => ToJSVal (a,b,c,d) where+ toJSVal (a,b,c,d) = join $ arr4 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d+ {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e) => ToJSVal (a,b,c,d,e) where+ toJSVal (a,b,c,d,e) = join $ arr5 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e+ {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f) => ToJSVal (a,b,c,d,e,f) where+ toJSVal (a,b,c,d,e,f) = join $ arr6 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e <*> toJSVal f+ {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f, ToJSVal g) => ToJSVal (a,b,c,d,e,f,g) where+ toJSVal (a,b,c,d,e,f,g) = join $ arr7 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e <*> toJSVal f <*> toJSVal g+ {-# INLINE toJSVal #-}++foreign import javascript unsafe "[$1]" arr1 :: JSVal -> IO JSVal+foreign import javascript unsafe "[$1,$2]" arr2 :: JSVal -> JSVal -> IO JSVal+foreign import javascript unsafe "[$1,$2,$3]" arr3 :: JSVal -> JSVal -> JSVal -> IO JSVal+foreign import javascript unsafe "[$1,$2,$3,$4]" arr4 :: JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal+foreign import javascript unsafe "[$1,$2,$3,$4,$5]" arr5 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal+foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6]" arr6 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal+foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7]" arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal++toJSVal_aeson :: AE.ToJSON a => a -> IO JSVal+toJSVal_aeson x = cv (AE.toJSON x)+ where+ cv = convertValue++ convertValue :: AE.Value -> IO JSVal+ convertValue AE.Null = return jsNull+ convertValue (AE.String t) = return (pToJSVal t)+ convertValue (AE.Array a) = (\(AI.SomeJSArray x) -> x) <$>+ (AI.fromListIO =<< mapM convertValue (V.toList a))+ convertValue (AE.Number n) = toJSVal (realToFrac n :: Double)+ convertValue (AE.Bool b) = return (toJSBool b)+ convertValue (AE.Object o) = do+ obj@(OI.Object obj') <- OI.create+ mapM_ (\(k,v) -> convertValue v >>= \v' -> OI.setProp (JSS.textToJSString k) v' obj) (H.toList o)+ return obj'++
+ GHCJS/Marshal/Internal.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,+ TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances+ #-}++module GHCJS.Marshal.Internal ( FromJSVal(..)+ , ToJSVal(..)+ , PToJSVal(..)+ , PFromJSVal(..)+ , Purity(..)+ , toJSVal_generic+ , fromJSVal_generic+ , toJSVal_pure+ , fromJSVal_pure+ , fromJSValUnchecked_pure+ ) where++import Control.Applicative+import Control.Monad++import Data.Data+import Data.Maybe+import Data.Typeable++import GHC.Generics++import qualified GHCJS.Prim as Prim+import qualified GHCJS.Foreign as F+import GHCJS.Types++import qualified Data.JSString.Internal.Type as JSS++import JavaScript.Array (MutableJSArray)+import qualified JavaScript.Array.Internal as AI+import JavaScript.Object (Object)+import qualified JavaScript.Object.Internal as OI++data Purity = PureShared -- ^ conversion is pure even if the original value is shared+ | PureExclusive -- ^ conversion is pure if the we only convert once+ deriving (Eq, Ord, Typeable, Data)++class PToJSVal a where+-- type PureOut a :: Purity+ pToJSVal :: a -> JSVal++class PFromJSVal a where+-- type PureIn a :: Purity+ pFromJSVal :: JSVal -> a++class ToJSVal a where+ toJSVal :: a -> IO JSVal++ toJSValListOf :: [a] -> IO JSVal+ toJSValListOf = Prim.toJSArray <=< mapM toJSVal++ -- default toJSVal :: PToJSVal a => a -> IO (JSVal a)+ -- toJSVal x = return (pToJSVal x)++ default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> IO JSVal+ toJSVal = toJSVal_generic id++class FromJSVal a where+ fromJSVal :: JSVal -> IO (Maybe a)++ fromJSValUnchecked :: JSVal -> IO a+ fromJSValUnchecked = fmap fromJust . fromJSVal+ {-# INLINE fromJSValUnchecked #-}++ fromJSValListOf :: JSVal -> IO (Maybe [a])+ fromJSValListOf = fmap sequence . (mapM fromJSVal <=< Prim.fromJSArray) -- fixme should check that it's an array++ fromJSValUncheckedListOf :: JSVal -> IO [a]+ fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< Prim.fromJSArray+ + -- default fromJSVal :: PFromJSVal a => JSVal a -> IO (Maybe a)+ -- fromJSVal x = return (Just (pFromJSVal x))++ default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> IO (Maybe a)+ fromJSVal = fromJSVal_generic id++ -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a+ -- fromJSValUnchecked x = return (pFromJSVal x)++-- -----------------------------------------------------------------------------++class GToJSVal a where+ gToJSVal :: (String -> String) -> Bool -> a -> IO JSVal++class GToJSProp a where+ gToJSProp :: (String -> String) -> JSVal -> a -> IO ()++class GToJSArr a where+ gToJSArr :: (String -> String) -> MutableJSArray -> a -> IO ()++instance (ToJSVal b) => GToJSVal (K1 a b c) where+ gToJSVal _ _ (K1 x) = toJSVal x++instance GToJSVal p => GToJSVal (Par1 p) where+ gToJSVal f b (Par1 p) = gToJSVal f b p++instance GToJSVal (f p) => GToJSVal (Rec1 f p) where+ gToJSVal f b (Rec1 x) = gToJSVal f b x++instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where+ gToJSVal f _ (L1 x) = gToJSVal f True x+ gToJSVal f _ (R1 x) = gToJSVal f True x++instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where+ gToJSVal f b m@(M1 x) = gToJSVal f b x++instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where+ gToJSVal f True m@(M1 x) = do+ obj@(OI.Object obj') <- OI.create+ v <- gToJSVal f (conIsRecord m) x+ OI.setProp (packJSS . f $ conName m) v obj+ return obj'+ gToJSVal f _ m@(M1 x) = gToJSVal f (conIsRecord m) x++instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => GToJSVal ((a :*: b) p) where+ gToJSVal f True xy = do+ (OI.Object obj') <- OI.create+ gToJSProp f obj' xy+ return obj'+ gToJSVal f False xy = do+ arr@(AI.SomeJSArray arr') <- AI.create+ gToJSArr f arr xy+ return arr'++instance GToJSVal (a p) => GToJSVal (M1 S c a p) where+ gToJSVal f b (M1 x) = gToJSVal f b x++instance (GToJSProp (a p), GToJSProp (b p)) => GToJSProp ((a :*: b) p) where+ gToJSProp f o (x :*: y) = gToJSProp f o x >> gToJSProp f o y++instance (Selector c, GToJSVal (a p)) => GToJSProp (M1 S c a p) where+ gToJSProp f o m@(M1 x) = do+ r <- gToJSVal f False x+ OI.setProp (packJSS . f $ selName m) r (OI.Object o)++instance (GToJSArr (a p), GToJSArr (b p)) => GToJSArr ((a :*: b) p) where+ gToJSArr f a (x :*: y) = gToJSArr f a x >> gToJSArr f a y++instance GToJSVal (a p) => GToJSArr (M1 S c a p) where+ gToJSArr f a (M1 x) = do+ r <- gToJSVal f False x+ AI.push r a++instance GToJSVal (V1 p) where+ gToJSVal _ _ _ = return Prim.jsNull++instance GToJSVal (U1 p) where+ gToJSVal _ _ _ = return F.jsTrue++toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))+ => (String -> String) -> a -> IO JSVal+toJSVal_generic f x = gToJSVal f False (from x :: Rep a ())++-- -----------------------------------------------------------------------------++class GFromJSVal a where+ gFromJSVal :: (String -> String) -> Bool -> JSVal -> IO (Maybe a)++class GFromJSProp a where+ gFromJSProp :: (String -> String) -> JSVal -> IO (Maybe a)++class GFromJSArr a where+ gFromJSArr :: (String -> String) -> MutableJSArray -> Int -> IO (Maybe (a,Int))++instance FromJSVal b => GFromJSVal (K1 a b c) where+ gFromJSVal _ _ r = fmap K1 <$> fromJSVal r++instance GFromJSVal p => GFromJSVal (Par1 p) where+ gFromJSVal f b r = gFromJSVal f b r++instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where+ gFromJSVal f b r = gFromJSVal f b r++instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where+ gFromJSVal f b r = do+ l <- gFromJSVal f True r+ case l of+ Just x -> return (L1 <$> Just x)+ Nothing -> fmap R1 <$> gFromJSVal f True r++instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where+ gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r++instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where+ gFromJSVal f True r = do+ r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)+ if isUndefined r'+ then return Nothing+ else fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'+ gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r++instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where+ gFromJSVal f True r = gFromJSProp f r+ gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0++instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where+ gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r++instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) where+ gFromJSProp f r = do+ a <- gFromJSProp f r+ case a of+ Nothing -> return Nothing+ Just a' -> fmap (a':*:) <$> gFromJSProp f r++instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where+ gFromJSProp f o = do+ p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)+ if isUndefined p+ then return Nothing+ else fmap M1 <$> gFromJSVal f False p++instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where+ gFromJSArr f r n = do+ a <- gFromJSArr f r 0+ case a of+ Just (a',an) -> do+ b <- gFromJSArr f r an+ case b of+ Just (b',bn) -> return (Just (a' :*: b',bn))+ _ -> return Nothing++instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where+ gFromJSArr f o n = do+ r <- AI.read n o+ if isUndefined r+ then return Nothing+ else fmap ((,n+1) . M1) <$> gFromJSVal f False r++instance GFromJSVal (V1 p) where+ gFromJSVal _ _ _ = return Nothing++instance GFromJSVal (U1 p) where+ gFromJSVal _ _ _ = return (Just U1)++fromJSVal_generic :: forall a . (Generic a, GFromJSVal (Rep a ()))+ => (String -> String) -> JSVal -> IO (Maybe a)+fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: IO (Maybe (Rep a ())))++-- -----------------------------------------------------------------------------++fromJSVal_pure :: PFromJSVal a => JSVal -> IO (Maybe a)+fromJSVal_pure x = return (Just (pFromJSVal x))+{-# INLINE fromJSVal_pure #-}++fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> IO a+fromJSValUnchecked_pure x = return (pFromJSVal x)+{-# INLINE fromJSValUnchecked_pure #-}++toJSVal_pure :: PToJSVal a => a -> IO JSVal+toJSVal_pure x = return (pToJSVal x)+{-# INLINE toJSVal_pure #-}++-- -----------------------------------------------------------------------------++packJSS :: String -> JSString+packJSS = JSS.JSString . Prim.toJSString
+ GHCJS/Marshal/Pure.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-+ experimental pure marshalling for lighter weight interaction in the quasiquoter+ -}+module GHCJS.Marshal.Pure ( PFromJSVal(..)+ , PToJSVal(..)+ ) where++import Data.Char (chr, ord)+import Data.Data+import Data.Int (Int8, Int16, Int32)+import Data.JSString.Internal.Type+import Data.Maybe+import Data.Text (Text)+import Data.Typeable+import Data.Word (Word8, Word16, Word32, Word)+import Data.JSString+import Data.JSString.Text+import Data.Bits ((.&.))+import Unsafe.Coerce (unsafeCoerce)+import GHC.Int+import GHC.Word+import GHC.Types+import GHC.Float+import GHC.Prim++import GHCJS.Types+import qualified GHCJS.Prim as Prim+import GHCJS.Foreign.Internal+import GHCJS.Marshal.Internal++{-+type family IsPureShared a where+ IsPureShared PureExclusive = False+ IsPureShared PureShared = True++type family IsPureExclusive a where+ IsPureExclusive PureExclusive = True+ IsPureExclusive PureShared = True+ -}++instance PFromJSVal JSVal where pFromJSVal = id+ {-# INLINE pFromJSVal #-}+instance PFromJSVal () where pFromJSVal _ = ()+ {-# INLINE pFromJSVal #-}++instance PFromJSVal JSString where pFromJSVal = JSString+ {-# INLINE pFromJSVal #-}+instance PFromJSVal [Char] where pFromJSVal = Prim.fromJSString+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Text where pFromJSVal = textFromJSVal+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Char where pFromJSVal x = C# (jsvalToChar x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Bool where pFromJSVal = isTruthy+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Int where pFromJSVal x = I# (jsvalToInt x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Int8 where pFromJSVal x = I8# (jsvalToInt8 x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Int16 where pFromJSVal x = I16# (jsvalToInt16 x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Int32 where pFromJSVal x = I32# (jsvalToInt x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Word where pFromJSVal x = W# (jsvalToWord x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Word8 where pFromJSVal x = W8# (jsvalToWord8 x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Word16 where pFromJSVal x = W16# (jsvalToWord16 x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Word32 where pFromJSVal x = W32# (jsvalToWord x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Float where pFromJSVal x = F# (jsvalToFloat x)+ {-# INLINE pFromJSVal #-}+instance PFromJSVal Double where pFromJSVal x = D# (jsvalToDouble x)+ {-# INLINE pFromJSVal #-}++instance PFromJSVal a => PFromJSVal (Maybe a) where+ pFromJSVal x | isUndefined x || isNull x = Nothing+ pFromJSVal x = Just (pFromJSVal x)+ {-# INLINE pFromJSVal #-}++instance PToJSVal JSVal where pToJSVal = id+ {-# INLINE pToJSVal #-}+instance PToJSVal JSString where pToJSVal = jsval+ {-# INLINE pToJSVal #-}+instance PToJSVal [Char] where pToJSVal = Prim.toJSString+ {-# INLINE pToJSVal #-}+instance PToJSVal Text where pToJSVal = jsval . textToJSString+ {-# INLINE pToJSVal #-}+instance PToJSVal Char where pToJSVal (C# c) = charToJSVal c+ {-# INLINE pToJSVal #-}+instance PToJSVal Bool where pToJSVal True = jsTrue+ pToJSVal False = jsFalse+ {-# INLINE pToJSVal #-}+instance PToJSVal Int where pToJSVal (I# x) = intToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Int8 where pToJSVal (I8# x) = intToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Int16 where pToJSVal (I16# x) = intToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Int32 where pToJSVal (I32# x) = intToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Word where pToJSVal (W# x) = wordToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Word8 where pToJSVal (W8# x) = wordToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Word16 where pToJSVal (W16# x) = wordToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Word32 where pToJSVal (W32# x) = wordToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Float where pToJSVal (F# x) = floatToJSVal x+ {-# INLINE pToJSVal #-}+instance PToJSVal Double where pToJSVal (D# x) = doubleToJSVal x+ {-# INLINE pToJSVal #-}++instance PToJSVal a => PToJSVal (Maybe a) where+ pToJSVal Nothing = jsNull+ pToJSVal (Just a) = pToJSVal a+ {-# INLINE pToJSVal #-}++foreign import javascript unsafe "$r = $1|0;" jsvalToWord :: JSVal -> Word#+foreign import javascript unsafe "$r = $1&0xff;" jsvalToWord8 :: JSVal -> Word#+foreign import javascript unsafe "$r = $1&0xffff;" jsvalToWord16 :: JSVal -> Word#+foreign import javascript unsafe "$r = $1|0;" jsvalToInt :: JSVal -> Int#+foreign import javascript unsafe "$r = $1<<24>>24;" jsvalToInt8 :: JSVal -> Int#+foreign import javascript unsafe "$r = $1<<16>>16;" jsvalToInt16 :: JSVal -> Int#+foreign import javascript unsafe "$r = +$1;" jsvalToFloat :: JSVal -> Float#+foreign import javascript unsafe "$r = +$1;" jsvalToDouble :: JSVal -> Double#+foreign import javascript unsafe "$r = $1&0x7fffffff;" jsvalToChar :: JSVal -> Char#++foreign import javascript unsafe "$r = $1;" wordToJSVal :: Word# -> JSVal+foreign import javascript unsafe "$r = $1;" intToJSVal :: Int# -> JSVal+foreign import javascript unsafe "$r = $1;" doubleToJSVal :: Double# -> JSVal+foreign import javascript unsafe "$r = $1;" floatToJSVal :: Float# -> JSVal+foreign import javascript unsafe "$r = $1;" charToJSVal :: Char# -> JSVal+
+ GHCJS/Nullable.hs view
@@ -0,0 +1,19 @@+module GHCJS.Nullable ( Nullable(..)+ , nullableToMaybe+ , maybeToNullable+ ) where++import GHCJS.Prim (JSVal(..))+import GHCJS.Marshal.Pure (PToJSVal(..), PFromJSVal(..))++newtype Nullable a = Nullable JSVal++nullableToMaybe :: PFromJSVal a => Nullable a -> Maybe a+nullableToMaybe (Nullable r) = pFromJSVal r+{-# INLINE nullableToMaybe #-}++maybeToNullable :: PToJSVal a => Maybe a -> Nullable a+maybeToNullable = Nullable . pToJSVal+{-# INLINE maybeToNullable #-}++
+ GHCJS/Types.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}++module GHCJS.Types ( JSVal+ , WouldBlockException(..)+ , JSException(..)+ , IsJSVal+ , jsval+ , isNull+ , isUndefined+ , nullRef+ , JSString+ , mkRef+ , Ref#+ , toPtr+ , fromPtr+ , JSRef+ ) where++import Data.JSString.Internal.Type (JSString)+import GHCJS.Internal.Types++import GHCJS.Prim++import GHC.Int+import GHC.Types+import GHC.Prim+import GHC.Ptr++import Control.DeepSeq++type Ref# = ByteArray#++mkRef :: ByteArray# -> JSVal+mkRef x = JSVal x++nullRef :: JSVal+nullRef = js_nullRef+{-# INLINE nullRef #-}++toPtr :: JSVal -> Ptr a+toPtr j = js_mkPtr j+{-# INLINE toPtr #-}++fromPtr :: Ptr a -> JSVal+fromPtr p = js_ptrVal p+{-# INLINE fromPtr #-}++foreign import javascript unsafe "$r = null;"+ js_nullRef :: JSVal++foreign import javascript unsafe "$r = $1_1;"+ js_ptrVal :: Ptr a -> JSVal++foreign import javascript unsafe "$r1 = $1; $r2 = 0;"+ js_mkPtr :: JSVal -> Ptr a++-- | This is a deprecated copmatibility wrapper for the old JSRef type.+--+-- See https://github.com/ghcjs/ghcjs/issues/421+type JSRef a = JSVal+{-# DEPRECATED JSRef "Use JSVal instead, or a more specific newtype wrapper of JSVal " #-}
+ JavaScript/Array.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}+module JavaScript.Array+ ( JSArray+ , MutableJSArray+ , create+ , length+ , lengthIO+ , null+ , fromList+ , fromListIO+ , toList+ , toListIO+ , index, (!)+ , read+ , write+ , append+ , push+ , pop+ , unshift+ , shift+ , reverse+ , take+ , takeIO+ , drop+ , dropIO+ , slice+ , sliceIO+ , freeze+ , unsafeFreeze+ , thaw+ , unsafeThaw+ ) where++import Prelude hiding (length, drop, read, take, reverse, null)++import qualified GHCJS.Prim as Prim+import GHCJS.Types++import JavaScript.Array.Internal (JSArray(..))+import JavaScript.Array.Internal++-- import qualified JavaScript.Array.Internal as I+{-+fromList :: [JSVal] -> IO (JSArray a)+fromList xs = fmap JSArray (I.fromList xs)+{-# INLINE fromList #-}++toList :: JSArray a -> IO [JSVal]+toList (JSArray x) = I.toList x+{-# INLINE toList #-}++create :: IO (JSArray a)+create = fmap JSArray I.create+{-# INLINE create #-}++length :: JSArray a -> IO Int+length (JSArray x) = I.length x+{-# INLINE length #-}++append :: JSArray a -> JSArray a -> IO (JSArray a)+append (JSArray x) (JSArray y) = fmap JSArray (I.append x y)+{-# INLINE append #-}+-}++(!) :: JSArray -> Int -> JSVal+x ! n = index n x+{-# INLINE (!) #-}++{-++index :: Int -> JSArray a -> IO JSVal+index n (JSArray x) = I.index n x+{-# INLINE index #-}++write :: Int -> JSVal -> JSArray a -> IO ()+write n e (JSArray x) = I.write n e x+{-# INLINE write #-}++drop :: Int -> JSArray a -> IO (JSArray a)+drop n (JSArray x) = fmap JSArray (I.drop n x)+{-# INLINE drop #-}++take :: Int -> JSArray a -> IO (JSArray a)+take n (JSArray x) = fmap JSArray (I.take n x)+{-# INLINE take #-}++slice :: Int -> Int -> JSArray a -> IO (JSArray a)+slice s n (JSArray x) = fmap JSArray (I.slice s n x)+{-# INLINE slice #-}++push :: JSVal -> JSArray a -> IO ()+push e (JSArray x) = I.push e x+{-# INLINE push #-}++pop :: JSArray a -> IO JSVal+pop (JSArray x) = I.pop x+{-# INLINE pop #-}++unshift :: JSVal -> JSArray a -> IO ()+unshift e (JSArray x) = I.unshift e x+{-# INLINE unshift #-}++shift :: JSArray a -> IO JSVal+shift (JSArray x) = I.shift x+{-# INLINE shift #-}++reverse :: JSArray a -> IO ()+reverse (JSArray x) = I.reverse x+{-# INLINE reverse #-}+-}+
+ JavaScript/Array/Internal.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, DataKinds, KindSignatures,+ PolyKinds, UnboxedTuples, GHCForeignImportPrim, DeriveDataTypeable,+ UnliftedFFITypes, MagicHash+ #-}+module JavaScript.Array.Internal where++import Prelude hiding (length, reverse, drop, take)++import Control.DeepSeq+import Data.Typeable+import Unsafe.Coerce (unsafeCoerce)++import GHC.Types+import GHC.IO+import qualified GHC.Exts as Exts+import GHC.Exts (State#)++import GHCJS.Internal.Types+import qualified GHCJS.Prim as Prim+import GHCJS.Types++newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal+ deriving (Typeable)+instance IsJSVal (SomeJSArray m)++type JSArray = SomeJSArray Immutable+type MutableJSArray = SomeJSArray Mutable++type STJSArray s = SomeJSArray (STMutable s)++create :: IO MutableJSArray+create = IO js_create+{-# INLINE create #-}++length :: JSArray -> Int+length x = js_lengthPure x+{-# INLINE length #-}++lengthIO :: SomeJSArray m -> IO Int+lengthIO x = IO (js_length x)+{-# INLINE lengthIO #-}++null :: JSArray -> Bool+null x = length x == 0+{-# INLINE null #-}++append :: SomeJSArray m -> SomeJSArray m -> IO (SomeJSArray m1)+append x y = IO (js_append x y)+{-# INLINE append #-}++fromList :: [JSVal] -> JSArray+fromList xs = rnf xs `seq` js_toJSArrayPure (unsafeCoerce xs)+{-# INLINE fromList #-}++fromListIO :: [JSVal] -> IO (SomeJSArray m)+fromListIO xs = IO (\s -> rnf xs `seq` js_toJSArray (unsafeCoerce xs) s)+{-# INLINE fromListIO #-}++toList :: JSArray -> [JSVal]+toList x = unsafeCoerce (js_fromJSArrayPure x)+{-# INLINE toList #-}++toListIO :: SomeJSArray m -> IO [JSVal]+toListIO x = IO $ \s -> case js_fromJSArray x s of+ (# s', xs #) -> (# s', unsafeCoerce xs #)+{-# INLINE toListIO #-}++index :: Int -> JSArray -> JSVal+index n x = js_indexPure n x+{-# INLINE index #-}++read :: Int -> SomeJSArray m -> IO JSVal+read n x = IO (js_index n x)+{-# INLINE read #-}++write :: Int -> JSVal -> MutableJSArray -> IO ()+write n e x = IO (js_setIndex n e x)+{-# INLINE write #-}++push :: JSVal -> MutableJSArray -> IO ()+push e x = IO (js_push e x)+{-# INLINE push #-}++pop :: MutableJSArray -> IO JSVal+pop x = IO (js_pop x)+{-# INLINE pop #-}++unshift :: JSVal -> MutableJSArray -> IO ()+unshift e x = IO (js_unshift e x)+{-# INLINE unshift #-}++shift :: MutableJSArray -> IO JSVal+shift x = IO (js_shift x)+{-# INLINE shift #-}++reverse :: MutableJSArray -> IO ()+reverse x = IO (js_reverse x)+{-# INLINE reverse #-}++take :: Int -> JSArray -> JSArray+take n x = js_slicePure 0 n x+{-# INLINE take #-}++takeIO :: Int -> SomeJSArray m -> IO (SomeJSArray m1)+takeIO n x = IO (js_slice 0 n x)+{-# INLINE takeIO #-}++drop :: Int -> JSArray -> JSArray+drop n x = js_slice1Pure n x+{-# INLINE drop #-}++dropIO :: Int -> SomeJSArray m -> IO (SomeJSArray m1)+dropIO n x = IO (js_slice1 n x)+{-# INLINE dropIO #-}++sliceIO :: Int -> Int -> JSArray -> IO (SomeJSArray m1)+sliceIO s n x = IO (js_slice s n x)+{-# INLINE sliceIO #-}++slice :: Int -> Int -> JSArray -> JSArray+slice s n x = js_slicePure s n x+{-# INLINE slice #-}++freeze :: MutableJSArray -> IO JSArray+freeze x = IO (js_slice1 0 x)+{-# INLINE freeze #-}++unsafeFreeze :: MutableJSArray -> IO JSArray+unsafeFreeze (SomeJSArray x) = pure (SomeJSArray x)+{-# INLINE unsafeFreeze #-}++thaw :: JSArray -> IO MutableJSArray+thaw x = IO (js_slice1 0 x)+{-# INLINE thaw #-}++unsafeThaw :: JSArray -> IO MutableJSArray+unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)+{-# INLINE unsafeThaw #-}+++-- -----------------------------------------------------------------------------++foreign import javascript unsafe "$r = [];"+ js_create :: State# s -> (# State# s, SomeJSArray m #)++foreign import javascript unsafe "$1.length"+ js_length :: SomeJSArray m -> State# s -> (# State# s, Int #)+foreign import javascript unsafe "$2[$1]"+ js_index :: Int -> SomeJSArray m -> State# s -> (# State# s, JSVal #)++foreign import javascript unsafe "$2[$1]"+ js_indexPure :: Int -> JSArray -> JSVal+foreign import javascript unsafe "$1.length"+ js_lengthPure :: JSArray -> Int++foreign import javascript unsafe "$3[$1] = $2"+ js_setIndex :: Int -> JSVal -> SomeJSArray m -> State# s -> (# State# s, () #)++foreign import javascript unsafe "$3.slice($1,$2)"+ js_slice :: Int -> Int -> SomeJSArray m -> State# s -> (# State# s, SomeJSArray m1 #)+foreign import javascript unsafe "$2.slice($1)"+ js_slice1 :: Int -> SomeJSArray m -> State# s -> (# State# s, SomeJSArray m1 #)++foreign import javascript unsafe "$3.slice($1,2)"+ js_slicePure :: Int -> Int -> JSArray -> JSArray+foreign import javascript unsafe "$2.slice($1)"+ js_slice1Pure :: Int -> JSArray -> JSArray++foreign import javascript unsafe "$1.concat($2)"+ js_append :: SomeJSArray m0 -> SomeJSArray m1 -> State# s -> (# State# s, SomeJSArray m2 #)++foreign import javascript unsafe "$2.push($1)"+ js_push :: JSVal -> SomeJSArray m -> State# s -> (# State# s, () #)+foreign import javascript unsafe "$1.pop()"+ js_pop :: SomeJSArray m -> State# s -> (# State# s, JSVal #)+foreign import javascript unsafe "$2.unshift($1)"+ js_unshift :: JSVal -> SomeJSArray m -> State# s -> (# State# s, () #)+foreign import javascript unsafe "$1.shift()"+ js_shift :: SomeJSArray m -> State# s -> (# State# s, JSVal #)++foreign import javascript unsafe "$1.reverse()"+ js_reverse :: SomeJSArray m -> State# s -> (# State# s, () #)++foreign import javascript unsafe "h$toHsListJSVal($1)"+ js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, Exts.Any #)+foreign import javascript unsafe "h$toHsListJSVal($1)"+ js_fromJSArrayPure :: JSArray -> Exts.Any -- [JSVal]++foreign import javascript unsafe "h$fromHsListJSVal($1)"+ js_toJSArray :: Exts.Any -> State# s -> (# State# s, SomeJSArray m #)+foreign import javascript unsafe "h$fromHsListJSVal($1)"+ js_toJSArrayPure :: Exts.Any -> JSArray+
+ JavaScript/Array/ST.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE Rank2Types, UnboxedTuples, MagicHash #-}++module JavaScript.Array.ST+ ( STJSArray+ , build+ , create+ , length+ , null+ , append+ , fromList+ , toList+ , read+ , write+ , push+ , pop+ , unshift+ , shift+ , reverse+ , take+ , drop+ , freeze+ , unsafeFreeze+ ) where++import qualified JavaScript.Array.Internal as I+import JavaScript.Array.Internal (SomeJSArray(..), JSArray, STJSArray)++import Prelude hiding (length, null, read, take, drop, reverse)+import GHC.ST++import GHCJS.Types+import Unsafe.Coerce+import Control.DeepSeq++build :: (forall s. STJSArray s -> ST s ()) -> JSArray+build m = runST $ do+ a <- create+ m a+ unsafeFreeze a+{-# INLINE build #-}++create :: ST s (STJSArray s)+create = ST I.js_create+{-# INLINE create #-}++length :: STJSArray s -> ST s Int+length x = ST (I.js_length x)+{-# INLINE length #-}++null :: STJSArray s -> ST s Bool+null = fmap (==0) . length+{-# INLINE null #-}++append :: STJSArray s -> STJSArray s -> ST s (STJSArray s)+append x y = ST (I.js_append x y)+{-# INLINE append #-}++fromList :: [JSVal] -> ST s (STJSArray s)+fromList xs = ST (\s -> rnf xs `seq` I.js_toJSArray (unsafeCoerce xs) s)+{-# INLINE fromList #-}++toList :: STJSArray s -> ST s [JSVal]+toList x = ST (unsafeCoerce (I.js_fromJSArray x))+{-# INLINE toList #-}++read :: Int -> STJSArray s -> ST s (JSVal)+read n x = ST (I.js_index n x)+{-# INLINE read #-}++write :: Int -> JSVal -> STJSArray s -> ST s ()+write n e x = ST (I.js_setIndex n e x)+{-# INLINE write #-}++push :: JSVal -> STJSArray s -> ST s ()+push e x = ST (I.js_push e x)+{-# INLINE push #-}++pop :: STJSArray s -> ST s JSVal+pop x = ST (I.js_pop x)+{-# INLINE pop #-}++unshift :: JSVal -> STJSArray s -> ST s ()+unshift e x = ST (I.js_unshift e x)+{-# INLINE unshift #-}++shift :: STJSArray s -> ST s JSVal+shift x = ST (I.js_shift x)+{-# INLINE shift #-}++reverse :: STJSArray s -> ST s ()+reverse x = ST (I.js_reverse x)+{-# INLINE reverse #-}++take :: Int -> STJSArray s -> ST s (STJSArray s)+take n x = ST (I.js_slice 0 n x)+{-# INLINE take #-}++drop :: Int -> STJSArray s -> ST s (STJSArray s)+drop n x = ST (I.js_slice1 n x)+{-# INLINE drop #-}++slice :: Int -> Int -> STJSArray s -> ST s (STJSArray s)+slice s n x = ST (I.js_slice s n x)+{-# INLINE slice #-}++freeze :: STJSArray s -> ST s JSArray+freeze x = ST (I.js_slice1 0 x)+{-# INLINE freeze #-}++unsafeFreeze :: STJSArray s -> ST s JSArray+unsafeFreeze (SomeJSArray x) = pure (SomeJSArray x)+{-# INLINE unsafeFreeze #-}
+ JavaScript/Cast.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, JavaScriptFFI #-}++module JavaScript.Cast ( Cast(..)+ , cast+ , unsafeCast+ ) where++import GHCJS.Prim++cast :: forall a. Cast a => JSVal -> Maybe a+cast x | js_checkCast x (instanceRef (undefined :: a)) = Just (unsafeWrap x)+ | otherwise = Nothing+{-# INLINE cast #-}++unsafeCast :: Cast a => JSVal -> a+unsafeCast x = unsafeWrap x+{-# INLINE unsafeCast #-}++class Cast a where+ unsafeWrap :: JSVal -> a+ instanceRef :: a -> JSVal++-- -----------------------------------------------------------------------------++foreign import javascript unsafe + "$1 instanceof $2" js_checkCast :: JSVal -> JSVal -> Bool
+ JavaScript/JSON.hs view
@@ -0,0 +1,12 @@+module JavaScript.JSON where++import JavaScript.JSON.Types+import JavaScript.JSON.Types.Internal++{-+class FromJSON a where+ parseJSON :: Value -> Parser a++class ToJSON a where+ toJSON :: a -> Value+-}
+ JavaScript/JSON/Types.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveDataTypeable, DefaultSignatures, FlexibleContexts #-}++module JavaScript.JSON.Types ( Value+ , Object+ , Options(..)+ , defaultOptions+ , SumEncoding(..)+ , defaultTaggedObject+ , camelTo+ ) where++import Control.Applicative+import Control.DeepSeq++import Data.Aeson.Types (Options(..), SumEncoding(..))++import Data.Maybe+import Data.Typeable+import Data.JSString++import GHC.Generics++import JavaScript.JSON.Types.Class+import JavaScript.JSON.Types.Internal+import qualified JavaScript.JSON.Types.Internal as I++runParser = undefined++-- | Run a 'Parser'.+parse :: (a -> Parser b) -> a -> Result b+parse m v = runParser (m v) Error Success+{-# INLINE parse #-}++-- | Run a 'Parser' with a 'Maybe' result type.+parseMaybe :: (a -> Parser b) -> a -> Maybe b+parseMaybe m v = runParser (m v) (const Nothing) Just+{-# INLINE parseMaybe #-}++-- | Run a 'Parser' with an 'Either' result type.+parseEither :: (a -> Parser b) -> a -> Either String b+parseEither m v = runParser (m v) Left Right+{-# INLINE parseEither #-}++-- | If the inner @Parser@ failed, modify the failure message using the+-- provided function. This allows you to create more descriptive error messages.+-- For example:+--+-- > parseJSON (Object o) = modifyFailure+-- > ("Parsing of the Foo value failed: " ++)+-- > (Foo <$> o .: "someField")+--+-- Since 0.6.2.0+modifyFailure :: (JSString -> JSString) -> Parser a -> Parser a+modifyFailure = undefined -- f (Parser p) = Parser $ \kf -> p (kf . f)++-- | Construct a 'Pair' from a key and a value.+(.=) :: ToJSON a => JSString -> a -> Pair+name .= value = (name, toJSON value)+{-# INLINE (.=) #-}++-- | Convert a value from JSON, failing if the types do not match.+fromJSON :: (FromJSON a) => Value -> Result a+fromJSON = I.parse parseJSON+{-# INLINE fromJSON #-}++(.:) :: FromJSON a => Object -> JSString -> Parser a+obj .: key = case I.lookup key obj of+ Nothing -> fail $ "key " ++ show key ++ " not present"+ Just v -> parseJSON v+{-# INLINE (.:) #-}++(.:?) :: FromJSON a => Object -> JSString -> Parser (Maybe a)+obj .:? key = case I.lookup key obj of+ Nothing -> pure Nothing+ Just v -> Just <$> parseJSON v+{-# INLINE (.:?) #-}++(.!=) :: Parser (Maybe a) -> a -> Parser a+pmval .!= val = fromMaybe val <$> pmval+{-# INLINE (.!=) #-}
+ JavaScript/JSON/Types/Class.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DefaultSignatures, FlexibleContexts #-}++module JavaScript.JSON.Types.Class (+ -- * Type classes+ -- ** Core JSON classes+ FromJSON(..)+ , ToJSON(..)++ -- ** Generic JSON classes+ , GFromJSON(..)+ , GToJSON(..)+ , genericToJSON+ , genericParseJSON+ ) where++import JavaScript.JSON.Types.Internal++import GHC.Generics++class GToJSON f where gToJSON :: Options -> f a -> Value+class GFromJSON f where gParseJSON :: Options -> Value -> Parser (f a)++genericToJSON :: (Generic a, GToJSON (Rep a)) => Options -> a -> Value+genericToJSON opts = gToJSON opts . from++genericParseJSON :: (Generic a, GFromJSON (Rep a)) => Options -> Value -> Parser a+genericParseJSON opts = fmap to . gParseJSON opts++class ToJSON a where+ toJSON :: a -> Value+ default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value+ toJSON = genericToJSON defaultOptions++class FromJSON a where+ parseJSON :: Value -> Parser a+ default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a+ parseJSON = genericParseJSON defaultOptions
+ JavaScript/JSON/Types/Generic.hs view
@@ -0,0 +1,618 @@+{-# LANGUAGE CPP, DefaultSignatures, EmptyDataDecls, FlexibleInstances,+ FunctionalDependencies, KindSignatures, OverlappingInstances,+ ScopedTypeVariables, TypeOperators, UndecidableInstances,+ ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards,+ RecordWildCards, DataKinds #-}++-- |+-- Module: Data.Aeson.Types.Generic+-- Copyright: (c) 2012 Bryan O'Sullivan+-- (c) 2011, 2012 Bas Van Dijk+-- (c) 2011 MailRank, Inc.+-- License: Apache+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: experimental+-- Portability: portable+--+-- Types for working with JSON data.++module JavaScript.JSON.Types.Generic ( ) where++import Control.Applicative ((<*>), (<$>), (<|>), pure)+import Control.Monad ((<=<))+import Control.Monad.ST (ST)+import JavaScript.Array (JSArray)+import JavaScript.JSON.Types.Instances+import JavaScript.JSON.Types.Internal+import qualified Data.JSString as JSS+import qualified JavaScript.JSON.Types.Internal as I+import qualified JavaScript.Array as JSA+import qualified JavaScript.Array.ST as JSAST+import Data.Bits++import Data.DList (DList, toList, empty)++import Data.JSString (JSString, pack, unpack)+import Data.Maybe (fromMaybe)+import Data.Monoid (mappend)++-- import Data.Text (Text, pack, unpack)++import GHC.Generics++{-+import qualified Data.HashMap.Strict as H+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+-}+--------------------------------------------------------------------------------+-- Generic toJSON++instance (GToJSON a) => GToJSON (M1 i c a) where+ -- Meta-information, which is not handled elsewhere, is ignored:+ gToJSON opts = gToJSON opts . unM1+ {-# INLINE gToJSON #-}++instance (ToJSON a) => GToJSON (K1 i a) where+ -- Constant values are encoded using their ToJSON instance:+ gToJSON _opts = toJSON . unK1+ {-# INLINE gToJSON #-}++instance GToJSON U1 where+ -- Empty constructors are encoded to an empty array:+ gToJSON _opts _ = emptyArray+ {-# INLINE gToJSON #-}++instance (ConsToJSON a) => GToJSON (C1 c a) where+ -- Constructors need to be encoded differently depending on whether they're+ -- a record or not. This distinction is made by 'constToJSON':+ gToJSON opts = consToJSON opts . unM1+ {-# INLINE gToJSON #-}++instance ( WriteProduct a, WriteProduct b+ , ProductSize a, ProductSize b ) => GToJSON (a :*: b) where+ -- Products are encoded to an array. Here we allocate a mutable vector of+ -- the same size as the product and write the product's elements to it using+ -- 'writeProduct':+ gToJSON opts p =+ arrayValue $ JSAST.build $ \a ->+ writeProduct opts a 0 lenProduct p+ where+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)+ productSize+ {-# INLINE gToJSON #-}++instance ( AllNullary (a :+: b) allNullary+ , SumToJSON (a :+: b) allNullary ) => GToJSON (a :+: b) where+ -- If all constructors of a sum datatype are nullary and the+ -- 'allNullaryToStringTag' option is set they are encoded to+ -- strings. This distinction is made by 'sumToJSON':+ gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)+ . sumToJSON opts+ {-# INLINE gToJSON #-}++--------------------------------------------------------------------------------++class SumToJSON f allNullary where+ sumToJSON :: Options -> f a -> Tagged allNullary Value++instance ( GetConName f+ , TaggedObject f+ , ObjectWithSingleField f+ , TwoElemArray f ) => SumToJSON f True where+ sumToJSON opts+ | allNullaryToStringTag opts = Tagged . stringValue . pack+ . constructorTagModifier opts . getConName+ | otherwise = Tagged . nonAllNullarySumToJSON opts+ {-# INLINE sumToJSON #-}++instance ( TwoElemArray f+ , TaggedObject f+ , ObjectWithSingleField f ) => SumToJSON f False where+ sumToJSON opts = Tagged . nonAllNullarySumToJSON opts+ {-# INLINE sumToJSON #-}++nonAllNullarySumToJSON :: ( TwoElemArray f+ , TaggedObject f+ , ObjectWithSingleField f+ ) => Options -> f a -> Value+nonAllNullarySumToJSON opts =+ case sumEncoding opts of+ TaggedObject{..} -> objectValue . object . taggedObject opts tagFieldName+ contentsFieldName+ ObjectWithSingleField -> objectValue . objectWithSingleField opts+ TwoElemArray -> arrayValue . twoElemArray opts+{-# INLINE nonAllNullarySumToJSON #-}++--------------------------------------------------------------------------------++class TaggedObject f where+ taggedObject :: Options -> String -> String -> f a -> [Pair]++instance ( TaggedObject a+ , TaggedObject b ) => TaggedObject (a :+: b) where+ taggedObject opts tagFieldName contentsFieldName (L1 x) =+ taggedObject opts tagFieldName contentsFieldName x+ taggedObject opts tagFieldName contentsFieldName (R1 x) =+ taggedObject opts tagFieldName contentsFieldName x+ {-# INLINE taggedObject #-}++instance ( IsRecord a isRecord+ , TaggedObject' a isRecord+ , Constructor c ) => TaggedObject (C1 c a) where+ taggedObject opts tagFieldName contentsFieldName =+ (pack tagFieldName .= constructorTagModifier opts+ (conName (undefined :: t c a p)) :) .+ (unTagged :: Tagged isRecord [Pair] -> [Pair]) .+ taggedObject' opts contentsFieldName . unM1+ {-# INLINE taggedObject #-}++class TaggedObject' f isRecord where+ taggedObject' :: Options -> String -> f a -> Tagged isRecord [Pair]++instance (RecordToPairs f) => TaggedObject' f True where+ taggedObject' opts _ = Tagged . toList . recordToPairs opts+ {-# INLINE taggedObject' #-}++instance (GToJSON f) => TaggedObject' f False where+ taggedObject' opts contentsFieldName =+ Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts+ {-# INLINE taggedObject' #-}++--------------------------------------------------------------------------------++-- | Get the name of the constructor of a sum datatype.+class GetConName f where+ getConName :: f a -> String++instance (GetConName a, GetConName b) => GetConName (a :+: b) where+ getConName (L1 x) = getConName x+ getConName (R1 x) = getConName x+ {-# INLINE getConName #-}++instance (Constructor c, GToJSON a, ConsToJSON a) => GetConName (C1 c a) where+ getConName = conName+ {-# INLINE getConName #-}++--------------------------------------------------------------------------------++class TwoElemArray f where+ twoElemArray :: Options -> f a -> JSArray -- V.Vector Value++instance (TwoElemArray a, TwoElemArray b) => TwoElemArray (a :+: b) where+ twoElemArray opts (L1 x) = twoElemArray opts x+ twoElemArray opts (R1 x) = twoElemArray opts x+ {-# INLINE twoElemArray #-}++instance ( GToJSON a, ConsToJSON a+ , Constructor c ) => TwoElemArray (C1 c a) where+ twoElemArray opts x = arrayValueList+ [ stringValue $ JSS.pack $ constructorTagModifier opts $ conName (undefined :: t c a p)+ , gToJSON opts x+ ]+ {-# INLINE twoElemArray #-}++--------------------------------------------------------------------------------++class ConsToJSON f where+ consToJSON :: Options -> f a -> Value++class ConsToJSON' f isRecord where+ consToJSON' :: Options -> f a -> Tagged isRecord Value++instance ( IsRecord f isRecord+ , ConsToJSON' f isRecord ) => ConsToJSON f where+ consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)+ . consToJSON' opts+ {-# INLINE consToJSON #-}++instance (RecordToPairs f) => ConsToJSON' f True where+ consToJSON' opts = Tagged . objectValue . object . toList . recordToPairs opts+ {-# INLINE consToJSON' #-}++instance GToJSON f => ConsToJSON' f False where+ consToJSON' opts = Tagged . gToJSON opts+ {-# INLINE consToJSON' #-}++--------------------------------------------------------------------------------++class RecordToPairs f where+ recordToPairs :: Options -> f a -> DList Pair++instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where+ recordToPairs opts (a :*: b) = recordToPairs opts a `mappend`+ recordToPairs opts b+ {-# INLINE recordToPairs #-}++instance (Selector s, GToJSON a) => RecordToPairs (S1 s a) where+ recordToPairs = fieldToPair+ {-# INLINE recordToPairs #-}++instance (Selector s, ToJSON a) => RecordToPairs (S1 s (K1 i (Maybe a))) where+ recordToPairs opts (M1 k1) | omitNothingFields opts+ , K1 Nothing <- k1 = empty+ recordToPairs opts m1 = fieldToPair opts m1+ {-# INLINE recordToPairs #-}++fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair+fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1+ , gToJSON opts (unM1 m1)+ )+{-# INLINE fieldToPair #-}++--------------------------------------------------------------------------------++class WriteProduct f where+ writeProduct :: Options+ -> JSAST.STJSArray s+ -> Int -- ^ index+ -> Int -- ^ length+ -> f a+ -> ST s ()++instance ( WriteProduct a+ , WriteProduct b ) => WriteProduct (a :*: b) where+ writeProduct opts mv ix len (a :*: b) = do+ writeProduct opts mv ix lenL a+ writeProduct opts mv ixR lenR b+ where+#if MIN_VERSION_base(4,5,0)+ lenL = len `unsafeShiftR` 1+#else+ lenL = len `shiftR` 1+#endif+ lenR = len - lenL+ ixR = ix + lenL+ {-# INLINE writeProduct #-}++instance (GToJSON a) => WriteProduct a where+ writeProduct opts mv ix _ = (\(SomeValue v) -> JSAST.write ix v mv) . gToJSON opts+ {-# INLINE writeProduct #-}++--------------------------------------------------------------------------------++class ObjectWithSingleField f where+ objectWithSingleField :: Options -> f a -> Object++instance ( ObjectWithSingleField a+ , ObjectWithSingleField b ) => ObjectWithSingleField (a :+: b) where+ objectWithSingleField opts (L1 x) = objectWithSingleField opts x+ objectWithSingleField opts (R1 x) = objectWithSingleField opts x+ {-# INLINE objectWithSingleField #-}++instance ( GToJSON a, ConsToJSON a+ , Constructor c ) => ObjectWithSingleField (C1 c a) where+ objectWithSingleField opts x = I.object [(typ, gToJSON opts x)]+ where+ typ = pack $ constructorTagModifier opts $+ conName (undefined :: t c a p)+ {-# INLINE objectWithSingleField #-}++--------------------------------------------------------------------------------+-- Generic parseJSON++instance (GFromJSON a) => GFromJSON (M1 i c a) where+ -- Meta-information, which is not handled elsewhere, is just added to the+ -- parsed value:+ gParseJSON opts = fmap M1 . gParseJSON opts+ {-# INLINE gParseJSON #-}++instance (FromJSON a) => GFromJSON (K1 i a) where+ -- Constant values are decoded using their FromJSON instance:+ gParseJSON _opts = fmap K1 . parseJSON+ {-# INLINE gParseJSON #-}++instance GFromJSON U1 where+ -- Empty constructors are expected to be encoded as an empty array:+ gParseJSON _opts v+ | isEmptyArray v = pure U1+ | otherwise = typeMismatch "unit constructor (U1)" v+ {-# INLINE gParseJSON #-}++instance (ConsFromJSON a) => GFromJSON (C1 c a) where+ -- Constructors need to be decoded differently depending on whether they're+ -- a record or not. This distinction is made by consParseJSON:+ gParseJSON opts = fmap M1 . consParseJSON opts+ {-# INLINE gParseJSON #-}++instance ( FromProduct a, FromProduct b+ , ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where+ -- Products are expected to be encoded to an array. Here we check whether we+ -- got an array of the same size as the product, then parse each of the+ -- product's elements using parseProduct:+ gParseJSON opts = withArray "product (:*:)" $ \arr ->+ let lenArray = JSA.length arr+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)+ productSize in+ if lenArray == lenProduct+ then parseProduct opts arr 0 lenProduct+ else fail $ "When expecting a product of " ++ show lenProduct +++ " values, encountered an Array of " ++ show lenArray +++ " elements instead"+ {-# INLINE gParseJSON #-}++instance ( AllNullary (a :+: b) allNullary+ , ParseSum (a :+: b) allNullary ) => GFromJSON (a :+: b) where+ -- If all constructors of a sum datatype are nullary and the+ -- 'allNullaryToStringTag' option is set they are expected to be+ -- encoded as strings. This distinction is made by 'parseSum':+ gParseJSON opts = (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->+ (Parser ((a :+: b) d)))+ . parseSum opts+ {-# INLINE gParseJSON #-}++--------------------------------------------------------------------------------++class ParseSum f allNullary where+ parseSum :: Options -> Value -> Tagged allNullary (Parser (f a))++instance ( SumFromString (a :+: b)+ , FromPair (a :+: b)+ , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) True where+ parseSum opts+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts+ | otherwise = Tagged . parseNonAllNullarySum opts+ {-# INLINE parseSum #-}++instance ( FromPair (a :+: b)+ , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) False where+ parseSum opts = Tagged . parseNonAllNullarySum opts+ {-# INLINE parseSum #-}++--------------------------------------------------------------------------------++parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)+parseAllNullarySum opts = withJSString "Text" $ \key ->+ maybe (notFound $ unpack key) return $+ parseSumFromString opts key+{-# INLINE parseAllNullarySum #-}++class SumFromString f where+ parseSumFromString :: Options -> JSString -> Maybe (f a)++instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where+ parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>+ (R1 <$> parseSumFromString opts key)+ {-# INLINE parseSumFromString #-}++instance (Constructor c) => SumFromString (C1 c U1) where+ parseSumFromString opts key | key == name = Just $ M1 U1+ | otherwise = Nothing+ where+ name = pack $ constructorTagModifier opts $+ conName (undefined :: t c U1 p)+ {-# INLINE parseSumFromString #-}++--------------------------------------------------------------------------------++parseNonAllNullarySum :: ( FromPair (a :+: b)+ , FromTaggedObject (a :+: b)+ ) => Options -> Value -> Parser ((a :+: b) c)+parseNonAllNullarySum opts =+ case sumEncoding opts of+ TaggedObject{..} ->+ withObject "Object" $ \obj -> do+ tag <- obj .: pack tagFieldName+ fromMaybe (notFound $ unpack tag) $+ parseFromTaggedObject opts contentsFieldName obj tag++ ObjectWithSingleField ->+ withObject "Object" $ \obj ->+ case objectAssocs obj of+ [pair@(tag, _)] -> fromMaybe (notFound $ unpack tag) $+ parsePair opts pair+ _ -> fail "Object doesn't have a single field"++ TwoElemArray ->+ withArray "Array" $ \arr ->+ if JSA.length arr == 2+ then case match (indexV arr 0) of+ String tag -> fromMaybe (notFound $ unpack tag) $+ parsePair opts (tag, indexV arr 1)+ _ -> fail "First element is not a String"+ else fail "Array doesn't have 2 elements"+{-# INLINE parseNonAllNullarySum #-}++--------------------------------------------------------------------------------++class FromTaggedObject f where+ parseFromTaggedObject :: Options -> String -> Object -> JSString+ -> Maybe (Parser (f a))++instance (FromTaggedObject a, FromTaggedObject b) =>+ FromTaggedObject (a :+: b) where+ parseFromTaggedObject opts contentsFieldName obj tag =+ (fmap L1 <$> parseFromTaggedObject opts contentsFieldName obj tag) <|>+ (fmap R1 <$> parseFromTaggedObject opts contentsFieldName obj tag)+ {-# INLINE parseFromTaggedObject #-}++instance ( FromTaggedObject' f+ , Constructor c ) => FromTaggedObject (C1 c f) where+ parseFromTaggedObject opts contentsFieldName obj tag+ | tag == name = Just $ M1 <$> parseFromTaggedObject'+ opts contentsFieldName obj+ | otherwise = Nothing+ where+ name = pack $ constructorTagModifier opts $+ conName (undefined :: t c f p)+ {-# INLINE parseFromTaggedObject #-}++--------------------------------------------------------------------------------++class FromTaggedObject' f where+ parseFromTaggedObject' :: Options -> String -> Object -> Parser (f a)++class FromTaggedObject'' f isRecord where+ parseFromTaggedObject'' :: Options -> String -> Object+ -> Tagged isRecord (Parser (f a))++instance ( IsRecord f isRecord+ , FromTaggedObject'' f isRecord+ ) => FromTaggedObject' f where+ parseFromTaggedObject' opts contentsFieldName =+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .+ parseFromTaggedObject'' opts contentsFieldName+ {-# INLINE parseFromTaggedObject' #-}++instance (FromRecord f) => FromTaggedObject'' f True where+ parseFromTaggedObject'' opts _ = Tagged . parseRecord opts+ {-# INLINE parseFromTaggedObject'' #-}++instance (GFromJSON f) => FromTaggedObject'' f False where+ parseFromTaggedObject'' opts contentsFieldName = Tagged .+ (gParseJSON opts <=< (.: pack contentsFieldName))+ {-# INLINE parseFromTaggedObject'' #-}++--------------------------------------------------------------------------------++class ConsFromJSON f where+ consParseJSON :: Options -> Value -> Parser (f a)++class ConsFromJSON' f isRecord where+ consParseJSON' :: Options -> Value -> Tagged isRecord (Parser (f a))++instance ( IsRecord f isRecord+ , ConsFromJSON' f isRecord+ ) => ConsFromJSON f where+ consParseJSON opts = (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))+ . consParseJSON' opts+ {-# INLINE consParseJSON #-}++instance (FromRecord f) => ConsFromJSON' f True where+ consParseJSON' opts = Tagged . (withObject "record (:*:)" $ parseRecord opts)+ {-# INLINE consParseJSON' #-}++instance (GFromJSON f) => ConsFromJSON' f False where+ consParseJSON' opts = Tagged . gParseJSON opts+ {-# INLINE consParseJSON' #-}++--------------------------------------------------------------------------------++class FromRecord f where+ parseRecord :: Options -> Object -> Parser (f a)++instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where+ parseRecord opts obj = (:*:) <$> parseRecord opts obj+ <*> parseRecord opts obj+ {-# INLINE parseRecord #-}++instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where+ parseRecord opts = maybe (notFound label) (gParseJSON opts)+ . I.lookup (pack label)+ where+ label = fieldLabelModifier opts $ selName (undefined :: t s a p)+ {-# INLINE parseRecord #-}++instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where+ parseRecord opts obj = (M1 . K1) <$> obj .:? pack label+ where+ label = fieldLabelModifier opts $+ selName (undefined :: t s (K1 i (Maybe a)) p)+ {-# INLINE parseRecord #-}++--------------------------------------------------------------------------------++class ProductSize f where+ productSize :: Tagged2 f Int++instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where+ productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) ++ unTagged2 (productSize :: Tagged2 b Int)+ {-# INLINE productSize #-}++instance ProductSize (S1 s a) where+ productSize = Tagged2 1+ {-# INLINE productSize #-}++--------------------------------------------------------------------------------++class FromProduct f where+ parseProduct :: Options -> JSArray -> Int -> Int -> Parser (f a)++instance (FromProduct a, FromProduct b) => FromProduct (a :*: b) where+ parseProduct opts arr ix len =+ (:*:) <$> parseProduct opts arr ix lenL+ <*> parseProduct opts arr ixR lenR+ where+#if MIN_VERSION_base(4,5,0)+ lenL = len `unsafeShiftR` 1+#else+ lenL = len `shiftR` 1+#endif+ ixR = ix + lenL+ lenR = len - lenL+ {-# INLINE parseProduct #-}++instance (GFromJSON a) => FromProduct (S1 s a) where+ parseProduct opts arr ix _ = gParseJSON opts $ indexV arr ix+ {-# INLINE parseProduct #-}++--------------------------------------------------------------------------------++class FromPair f where+ parsePair :: Options -> Pair -> Maybe (Parser (f a))++instance (FromPair a, FromPair b) => FromPair (a :+: b) where+ parsePair opts pair = (fmap L1 <$> parsePair opts pair) <|>+ (fmap R1 <$> parsePair opts pair)+ {-# INLINE parsePair #-}++instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where+ parsePair opts (tag, value)+ | tag == tag' = Just $ gParseJSON opts value+ | otherwise = Nothing+ where+ tag' = pack $ constructorTagModifier opts $+ conName (undefined :: t c a p)+ {-# INLINE parsePair #-}++--------------------------------------------------------------------------------++class IsRecord (f :: * -> *) isRecord | f -> isRecord++instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord+#if MIN_VERSION_base(4,9,0)+instance IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False+#else+instance IsRecord (M1 S NoSelector f) False+#endif+instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord+instance IsRecord (K1 i c) True+instance IsRecord U1 False++--------------------------------------------------------------------------------++class AllNullary (f :: * -> *) allNullary | f -> allNullary++instance ( AllNullary a allNullaryL+ , AllNullary b allNullaryR+ , And allNullaryL allNullaryR allNullary+ ) => AllNullary (a :+: b) allNullary+instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary+instance AllNullary (a :*: b) False+instance AllNullary (K1 i c) False+instance AllNullary U1 True++--------------------------------------------------------------------------------++data True+data False++class And bool1 bool2 bool3 | bool1 bool2 -> bool3++instance And True True True+instance And False False False+instance And False True False+instance And True False False++--------------------------------------------------------------------------------++newtype Tagged s b = Tagged {unTagged :: b}++newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}++--------------------------------------------------------------------------------++notFound :: String -> Parser a+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"+{-# INLINE notFound #-}
+ JavaScript/JSON/Types/Instances.hs view
@@ -0,0 +1,1088 @@+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+ GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,+ OverloadedStrings, UndecidableInstances, ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE DefaultSignatures #-}++-- |+-- Module: Data.Aeson.Types.Instances+-- Copyright: (c) 2011-2013 Bryan O'Sullivan+-- (c) 2011 MailRank, Inc.+-- License: Apache+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: experimental+-- Portability: portable+--+-- Types for working with JSON data.++module JavaScript.JSON.Types.Instances+ (+ -- * Type classes+ -- ** Core JSON classes+ FromJSON(..)+ , ToJSON(..)++ -- ** Generic JSON classes+ , GFromJSON(..)+ , GToJSON(..)+ , genericToJSON+ , genericParseJSON++ -- * Types+ , DotNetTime(..)++ -- * Inspecting @'Value's@+ , withObject+ , withJSString+ , withArray+ , withDouble+ , withBool++ -- * Functions+ , fromJSON+ , (.:)+ , (.:?)+ , (.!=)+ , (.=)+ , typeMismatch+ ) where++import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)+-- import Data.Aeson.Functions+-- import JavaScript.JSON.Functions+-- import Data.Aeson.Types.Class++-- import Data.Aeson.Types.Internal++import Data.JSString (JSString)+import qualified Data.JSString as JSS+import qualified Data.JSString.Text as JSS++import JavaScript.Array (JSArray)+import qualified JavaScript.Array as JSA++import JavaScript.JSON.Types.Class+import JavaScript.JSON.Types.Internal+import qualified JavaScript.JSON.Types.Internal as I++import Data.Scientific (Scientific)+import qualified Data.Scientific as Scientific (coefficient, base10Exponent, fromFloatDigits, toRealFloat)+import Data.Attoparsec.Number (Number(..))+import Data.Fixed+import Data.Hashable (Hashable(..))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Maybe (fromMaybe)+import Data.Monoid (Dual(..), First(..), Last(..), mappend)+import Data.Ratio (Ratio, (%), numerator, denominator)+import Data.Text (Text, pack, unpack)+import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))+import Data.Time.Format (FormatTime, formatTime, parseTime)+import Data.Traversable (traverse)+import Data.Vector (Vector)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import Foreign.Storable (Storable)+-- #if MIN_VERSION_time(1,5,0)+import Data.Time.Format(defaultTimeLocale, dateTimeFmt)+-- #else+-- import System.Locale (defaultTimeLocale, dateTimeFmt)+-- #endif+import Unsafe.Coerce++import qualified Data.HashMap.Strict as H+import qualified Data.HashSet as HashSet+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as M+import qualified Data.Set as Set+import qualified Data.Tree as Tree+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )++instance (ToJSON a) => ToJSON (Maybe a) where+ toJSON (Just a) = toJSON a+ toJSON Nothing = nullValue+ {-# INLINE toJSON #-}++instance (FromJSON a) => FromJSON (Maybe a) where+ parseJSON (match -> Null) = pure Nothing+ parseJSON a = Just <$> parseJSON a+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where+ toJSON (Left a) = objectValue $ object [left .= a]+ toJSON (Right b) = objectValue $ object [right .= b]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where+ parseJSON (match -> (Object (objectAssocs -> [(key, value)])))+ | key == left = Left <$> parseJSON value+ | key == right = Right <$> parseJSON value+ parseJSON _ = fail $+ "expected an object with a single property " +++ "where the property key should be either " +++ "\"Left\" or \"Right\""+ {-# INLINE parseJSON #-}++left, right :: JSString+left = "Left"+right = "Right"++instance ToJSON Bool where+ toJSON = boolValue+ {-# INLINE toJSON #-}++instance FromJSON Bool where+ parseJSON = withBool "Bool" pure+ {-# INLINE parseJSON #-}++instance ToJSON () where+ toJSON _ = emptyArray+ {-# INLINE toJSON #-}++instance FromJSON () where+ parseJSON = withArray "()" $ \v ->+ if JSA.null v+ then pure ()+ else fail "Expected an empty array"+ {-# INLINE parseJSON #-}++instance ToJSON [Char] where+ toJSON = stringValue . JSS.pack+ {-# INLINE toJSON #-}++instance FromJSON [Char] where+ parseJSON = withJSString "String" $ pure . JSS.unpack+ {-# INLINE parseJSON #-}++instance ToJSON Char where+ toJSON = stringValue . JSS.singleton+ {-# INLINE toJSON #-}++instance FromJSON Char where+ parseJSON = withJSString "Char" $ \t ->+ if JSS.compareLength t 1 == EQ+ then pure $ JSS.head t+ else fail "Expected a string of length 1"+ {-# INLINE parseJSON #-}++{-+instance ToJSON Scientific where+ toJSON = Number+ {-# INLINE toJSON #-}++instance FromJSON Scientific where+ parseJSON = withScientific "Scientific" pure+ {-# INLINE parseJSON #-}+-}++instance ToJSON Double where+ toJSON = doubleValue+ {-# INLINE toJSON #-}++instance FromJSON Double where+ parseJSON = withDouble "Double" pure+ {-# INLINE parseJSON #-}++{-+instance ToJSON Number where+ toJSON (D d) = toJSON d+ toJSON (I i) = toJSON i+ {-# INLINE toJSON #-}++instance FromJSON Number where+ parseJSON (Number s) = pure $ scientificToNumber s+ parseJSON Null = pure (D (0/0))+ parseJSON v = typeMismatch "Number" v+ {-# INLINE parseJSON #-}+-}++instance ToJSON Float where+ toJSON = doubleValue . realToFrac -- realFloatToJSON+ {-# INLINE toJSON #-}++instance FromJSON Float where+ parseJSON = withDouble "Float" (pure . realToFrac)+ {-# INLINE parseJSON #-}++instance ToJSON (Ratio Integer) where+ toJSON r = objectValue $ object [ "numerator" .= numerator r+ , "denominator" .= denominator r+ ]+ {-# INLINE toJSON #-}++instance FromJSON (Ratio Integer) where+ parseJSON = withObject "Rational" $ \obj ->+ (%) <$> obj .: "numerator"+ <*> obj .: "denominator"+ {-# INLINE parseJSON #-}++instance HasResolution a => ToJSON (Fixed a) where+ toJSON = doubleValue . realToFrac+ {-# INLINE toJSON #-}++-- | /WARNING:/ Only parse fixed-precision numbers from trusted input+-- since an attacker could easily fill up the memory of the target+-- system by specifying a scientific number with a big exponent like+-- @1e1000000000@.+instance HasResolution a => FromJSON (Fixed a) where+ parseJSON = withDouble "Fixed" $ pure . realToFrac+ {-# INLINE parseJSON #-}++instance ToJSON Int where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Int where+ parseJSON = parseIntegral "Int"+ {-# INLINE parseJSON #-}++instance ToJSON Integer where+ toJSON = doubleValue . fromInteger+ {-# INLINE toJSON #-}++-- | /WARNING:/ Only parse Integers from trusted input since an+-- attacker could easily fill up the memory of the target system by+-- specifying a scientific number with a big exponent like+-- @1e1000000000@.+instance FromJSON Integer where+ parseJSON = withDouble "Integral" $ pure . floor -- withScientific "Integral" $ pure . floor+ {-# INLINE parseJSON #-}++instance ToJSON Int8 where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Int8 where+ parseJSON = parseIntegral "Int8"+ {-# INLINE parseJSON #-}++instance ToJSON Int16 where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Int16 where+ parseJSON = parseIntegral "Int16"+ {-# INLINE parseJSON #-}++instance ToJSON Int32 where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Int32 where+ parseJSON = parseIntegral "Int32"+ {-# INLINE parseJSON #-}++instance ToJSON Int64 where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Int64 where+ parseJSON = parseIntegral "Int64"+ {-# INLINE parseJSON #-}++instance ToJSON Word where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Word where+ parseJSON = parseIntegral "Word"+ {-# INLINE parseJSON #-}++instance ToJSON Word8 where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Word8 where+ parseJSON = parseIntegral "Word8"+ {-# INLINE parseJSON #-}++instance ToJSON Word16 where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Word16 where+ parseJSON = parseIntegral "Word16"+ {-# INLINE parseJSON #-}++instance ToJSON Word32 where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Word32 where+ parseJSON = parseIntegral "Word32"+ {-# INLINE parseJSON #-}++instance ToJSON Word64 where+ toJSON = doubleValue . fromIntegral+ {-# INLINE toJSON #-}++instance FromJSON Word64 where+ parseJSON = parseIntegral "Word64"+ {-# INLINE parseJSON #-}++instance ToJSON JSString where+ toJSON = stringValue+ {-# INLINE toJSON #-}++instance FromJSON JSString where+ parseJSON = withJSString "JSString" pure+ {-# INLINE parseJSON #-}++instance ToJSON Text where+ toJSON = stringValue . JSS.textToJSString+ {-# INLINE toJSON #-}++instance FromJSON Text where+ parseJSON = withJSString "Text" ( pure . JSS.textFromJSString )+ {-# INLINE parseJSON #-}++instance ToJSON LT.Text where+ toJSON = stringValue . JSS.textToJSString . LT.toStrict+ {-# INLINE toJSON #-}++instance FromJSON LT.Text where+ parseJSON = withJSString "Lazy Text" $ pure . LT.fromStrict . JSS.textFromJSString+ {-# INLINE parseJSON #-}++instance (ToJSON a) => ToJSON [a] where+ toJSON = arrayValue . arrayValueList . map toJSON+ {-# INLINE toJSON #-}++instance (FromJSON a) => FromJSON [a] where+ parseJSON = withArray "[a]" $ mapM parseJSON . arrayToValueList+ {-# INLINE parseJSON #-}++{-+instance (ToJSON a) => ToJSON (Vector a) where+ toJSON = Array . V.map toJSON+ {-# INLINE toJSON #-}++instance (FromJSON a) => FromJSON (Vector a) where+ parseJSON = withArray "Vector a" $ V.mapM parseJSON+ {-# INLINE parseJSON #-}++vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value+vectorToJSON = Array . V.map toJSON . V.convert+{-# INLINE vectorToJSON #-}++vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)+vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON+{-# INLINE vectorParseJSON #-}++instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where+ toJSON = vectorToJSON++instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"++instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where+ toJSON = vectorToJSON++instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"++instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where+ toJSON = vectorToJSON++instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"+-}++instance (ToJSON a) => ToJSON (Set.Set a) where+ toJSON = toJSON . Set.toList+ {-# INLINE toJSON #-}++instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where+ parseJSON = fmap Set.fromList . parseJSON+ {-# INLINE parseJSON #-}++instance (ToJSON a) => ToJSON (HashSet.HashSet a) where+ toJSON = toJSON . HashSet.toList+ {-# INLINE toJSON #-}++instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where+ parseJSON = fmap HashSet.fromList . parseJSON+ {-# INLINE parseJSON #-}++instance ToJSON IntSet.IntSet where+ toJSON = toJSON . IntSet.toList+ {-# INLINE toJSON #-}++instance FromJSON IntSet.IntSet where+ parseJSON = fmap IntSet.fromList . parseJSON+ {-# INLINE parseJSON #-}++instance ToJSON a => ToJSON (IntMap.IntMap a) where+ toJSON = toJSON . IntMap.toList+ {-# INLINE toJSON #-}++instance FromJSON a => FromJSON (IntMap.IntMap a) where+ parseJSON = fmap IntMap.fromList . parseJSON+ {-# INLINE parseJSON #-}+{-+instance (ToJSON v) => ToJSON (M.Map Text v) where+ toJSON = Object . M.foldrWithKey (\k -> H.insert k . toJSON) H.empty+ {-# INLINE toJSON #-}++instance (FromJSON v) => FromJSON (M.Map Text v) where+ parseJSON = withObject "Map Text a" $+ fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON++instance (ToJSON v) => ToJSON (M.Map LT.Text v) where+ toJSON = Object . mapHashKeyVal LT.toStrict toJSON++instance (FromJSON v) => FromJSON (M.Map LT.Text v) where+ parseJSON = fmap (hashMapKey LT.fromStrict) . parseJSON++instance (ToJSON v) => ToJSON (M.Map String v) where+ toJSON = Object . mapHashKeyVal pack toJSON++instance (FromJSON v) => FromJSON (M.Map String v) where+ parseJSON = fmap (hashMapKey unpack) . parseJSON++instance (ToJSON v) => ToJSON (H.HashMap Text v) where+ toJSON = Object . H.map toJSON+ {-# INLINE toJSON #-}++instance (FromJSON v) => FromJSON (H.HashMap Text v) where+ parseJSON = withObject "HashMap Text a" $ traverse parseJSON++instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where+ toJSON = Object . mapKeyVal LT.toStrict toJSON++instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where+ parseJSON = fmap (mapKey LT.fromStrict) . parseJSON++instance (ToJSON v) => ToJSON (H.HashMap String v) where+ toJSON = Object . mapKeyVal pack toJSON++instance (FromJSON v) => FromJSON (H.HashMap String v) where+ parseJSON = fmap (mapKey unpack) . parseJSON++instance (ToJSON v) => ToJSON (Tree.Tree v) where+ toJSON (Tree.Node root branches) = toJSON (root,branches)++instance (FromJSON v) => FromJSON (Tree.Tree v) where+ parseJSON j = uncurry Tree.Node <$> parseJSON j+-}++instance ToJSON Value where+ toJSON a = a+ {-# INLINE toJSON #-}++instance FromJSON Value where+ parseJSON a = pure a+ {-# INLINE parseJSON #-}++instance ToJSON DotNetTime where+ toJSON (DotNetTime t) =+ stringValue (JSS.pack (secs ++ formatMillis t ++ ")/"))+ where secs = formatTime defaultTimeLocale "/Date(%s" t+ {-# INLINE toJSON #-}++instance FromJSON DotNetTime where+ parseJSON = withJSString "DotNetTime" $ \t ->+ let (s,m) = JSS.splitAt (JSS.length t - 5) t+ t' = JSS.concat [s,".",m]+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (JSS.unpack t') of+ Just d -> pure (DotNetTime d)+ _ -> fail "could not parse .NET time"+ {-# INLINE parseJSON #-}++instance ToJSON ZonedTime where+ toJSON t = stringValue $ JSS.pack $ formatTime defaultTimeLocale format t+ where+ format = "%FT%T." ++ formatMillis t ++ tzFormat+ tzFormat+ | 0 == timeZoneMinutes (zonedTimeZone t) = "Z"+ | otherwise = "%z"++formatMillis :: (FormatTime t) => t -> String+formatMillis t = take 3 . formatTime defaultTimeLocale "%q" $ t++instance FromJSON ZonedTime where+ parseJSON (match -> String t) =+ tryFormats alternateFormats+ <|> fail "could not parse ECMA-262 ISO-8601 date"+ where+ tryFormat f =+ case parseTime defaultTimeLocale f (JSS.unpack t) of+ Just d -> pure d+ Nothing -> empty+ tryFormats = foldr1 (<|>) . map tryFormat+ alternateFormats =+ dateTimeFmt defaultTimeLocale :+ distributeList ["%Y", "%Y-%m", "%F"]+ ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]++ distributeList xs ys =+ foldr (\x acc -> acc ++ distribute x ys) [] xs+ distribute x = map (mappend x)++ parseJSON v = typeMismatch "ZonedTime" v++instance ToJSON UTCTime where+ toJSON t = stringValue $ JSS.pack $ formatTime defaultTimeLocale format t+ where+ format = "%FT%T." ++ formatMillis t ++ "Z"+ {-# INLINE toJSON #-}++instance FromJSON UTCTime where+ parseJSON = withJSString "UTCTime" $ \t ->+ case parseTime defaultTimeLocale "%FT%T%QZ" (JSS.unpack t) of+ Just d -> pure d+ _ -> fail "could not parse ISO-8601 date"+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b) => ToJSON (a,b) where+ toJSON (a,b) = arrayValue $ arrayValueList+ [toJSON a, toJSON b]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b) => FromJSON (a,b) where+ parseJSON = withArray "(a,b)" $ \ab ->+ let n = JSA.length ab+ in if n == 2+ then (,) <$> parseJSON (indexV ab 0)+ <*> parseJSON (indexV ab 1)+ else fail $ "cannot unpack array of length " +++ show n ++ " into a pair"+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where+ toJSON (a,b,c) = arrayValue $ arrayValueList+ [toJSON a, toJSON b, toJSON c]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where+ parseJSON = withArray "(a,b,c)" $ \abc ->+ let n = JSA.length abc+ in if n == 3+ then (,,) <$> parseJSON (indexV abc 0)+ <*> parseJSON (indexV abc 1)+ <*> parseJSON (indexV abc 2)+ else fail $ "cannot unpack array of length " +++ show n ++ " into a 3-tuple"+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where+ toJSON (a,b,c,d) = arrayValue $ arrayValueList+ [toJSON a, toJSON b, toJSON c, toJSON d]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) =>+ FromJSON (a,b,c,d) where+ parseJSON = withArray "(a,b,c,d)" $ \abcd ->+ let n = JSA.length abcd+ in if n == 4+ then (,,,) <$> parseJSON (indexV abcd 0)+ <*> parseJSON (indexV abcd 1)+ <*> parseJSON (indexV abcd 2)+ <*> parseJSON (indexV abcd 3)+ else fail $ "cannot unpack array of length " +++ show n ++ " into a 4-tuple"+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) =>+ ToJSON (a,b,c,d,e) where+ toJSON (a,b,c,d,e) = arrayValue $ arrayValueList+ [toJSON a, toJSON b, toJSON c, toJSON d, toJSON e]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) =>+ FromJSON (a,b,c,d,e) where+ parseJSON = withArray "(a,b,c,d,e)" $ \abcde ->+ let n = JSA.length abcde+ in if n == 5+ then (,,,,) <$> parseJSON (indexV abcde 0)+ <*> parseJSON (indexV abcde 1)+ <*> parseJSON (indexV abcde 2)+ <*> parseJSON (indexV abcde 3)+ <*> parseJSON (indexV abcde 4)+ else fail $ "cannot unpack array of length " +++ show n ++ " into a 5-tuple"+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) =>+ ToJSON (a,b,c,d,e,f) where+ toJSON (a,b,c,d,e,f) = arrayValue $ arrayValueList+ [toJSON a, toJSON b, toJSON c, toJSON d, toJSON e, toJSON f]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f) => FromJSON (a,b,c,d,e,f) where+ parseJSON = withArray "(a,b,c,d,e,f)" $ \abcdef ->+ let n = JSA.length abcdef+ in if n == 6+ then (,,,,,) <$> parseJSON (indexV abcdef 0)+ <*> parseJSON (indexV abcdef 1)+ <*> parseJSON (indexV abcdef 2)+ <*> parseJSON (indexV abcdef 3)+ <*> parseJSON (indexV abcdef 4)+ <*> parseJSON (indexV abcdef 5)+ else fail $ "cannot unpack array of length " +++ show n ++ " into a 6-tuple"+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g) => ToJSON (a,b,c,d,e,f,g) where+ toJSON (a,b,c,d,e,f,g) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g) => FromJSON (a,b,c,d,e,f,g) where+ parseJSON = withArray "(a,b,c,d,e,f,g)" $ \abcdefg ->+ let n = JSA.length abcdefg+ in if n == 7+ then (,,,,,,) <$> parseJSON (indexV abcdefg 0)+ <*> parseJSON (indexV abcdefg 1)+ <*> parseJSON (indexV abcdefg 2)+ <*> parseJSON (indexV abcdefg 3)+ <*> parseJSON (indexV abcdefg 4)+ <*> parseJSON (indexV abcdefg 5)+ <*> parseJSON (indexV abcdefg 6)+ else fail $ "cannot unpack array of length " +++ show n ++ " into a 7-tuple"+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g, ToJSON h) => ToJSON (a,b,c,d,e,f,g,h) where+ toJSON (a,b,c,d,e,f,g,h) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g, toJSON h]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g, FromJSON h) =>+ FromJSON (a,b,c,d,e,f,g,h) where+ parseJSON = withArray "(a,b,c,d,e,f,g,h)" $ \ary ->+ let n = JSA.length ary+ in if n /= 8+ then fail $ "cannot unpack array of length " +++ show n ++ " into an 8-tuple"+ else (,,,,,,,)+ <$> parseJSON (indexV ary 0)+ <*> parseJSON (indexV ary 1)+ <*> parseJSON (indexV ary 2)+ <*> parseJSON (indexV ary 3)+ <*> parseJSON (indexV ary 4)+ <*> parseJSON (indexV ary 5)+ <*> parseJSON (indexV ary 6)+ <*> parseJSON (indexV ary 7)+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g, ToJSON h, ToJSON i) => ToJSON (a,b,c,d,e,f,g,h,i) where+ toJSON (a,b,c,d,e,f,g,h,i) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g, toJSON h+ , toJSON i]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g, FromJSON h, FromJSON i) =>+ FromJSON (a,b,c,d,e,f,g,h,i) where+ parseJSON = withArray "(a,b,c,d,e,f,g,h,i)" $ \ary ->+ let n = JSA.length ary+ in if n /= 9+ then fail $ "cannot unpack array of length " +++ show n ++ " into a 9-tuple"+ else (,,,,,,,,)+ <$> parseJSON (indexV ary 0)+ <*> parseJSON (indexV ary 1)+ <*> parseJSON (indexV ary 2)+ <*> parseJSON (indexV ary 3)+ <*> parseJSON (indexV ary 4)+ <*> parseJSON (indexV ary 5)+ <*> parseJSON (indexV ary 6)+ <*> parseJSON (indexV ary 7)+ <*> parseJSON (indexV ary 8)+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g, ToJSON h, ToJSON i, ToJSON j) =>+ ToJSON (a,b,c,d,e,f,g,h,i,j) where+ toJSON (a,b,c,d,e,f,g,h,i,j) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g, toJSON h+ , toJSON i, toJSON j]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) =>+ FromJSON (a,b,c,d,e,f,g,h,i,j) where+ parseJSON = withArray "(a,b,c,d,e,f,g,h,i,j)" $ \ary ->+ let n = JSA.length ary+ in if n /= 10+ then fail $ "cannot unpack array of length " +++ show n ++ " into a 10-tuple"+ else (,,,,,,,,,)+ <$> parseJSON (indexV ary 0)+ <*> parseJSON (indexV ary 1)+ <*> parseJSON (indexV ary 2)+ <*> parseJSON (indexV ary 3)+ <*> parseJSON (indexV ary 4)+ <*> parseJSON (indexV ary 5)+ <*> parseJSON (indexV ary 6)+ <*> parseJSON (indexV ary 7)+ <*> parseJSON (indexV ary 8)+ <*> parseJSON (indexV ary 9)+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) =>+ ToJSON (a,b,c,d,e,f,g,h,i,j,k) where+ toJSON (a,b,c,d,e,f,g,h,i,j,k) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g, toJSON h+ , toJSON i, toJSON j, toJSON k]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j,+ FromJSON k) =>+ FromJSON (a,b,c,d,e,f,g,h,i,j,k) where+ parseJSON = withArray "(a,b,c,d,e,f,g,h,i,j,k)" $ \ary ->+ let n = JSA.length ary+ in if n /= 11+ then fail $ "cannot unpack array of length " +++ show n ++ " into an 11-tuple"+ else (,,,,,,,,,,)+ <$> parseJSON (indexV ary 0)+ <*> parseJSON (indexV ary 1)+ <*> parseJSON (indexV ary 2)+ <*> parseJSON (indexV ary 3)+ <*> parseJSON (indexV ary 4)+ <*> parseJSON (indexV ary 5)+ <*> parseJSON (indexV ary 6)+ <*> parseJSON (indexV ary 7)+ <*> parseJSON (indexV ary 8)+ <*> parseJSON (indexV ary 9)+ <*> parseJSON (indexV ary 10)+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l) =>+ ToJSON (a,b,c,d,e,f,g,h,i,j,k,l) where+ toJSON (a,b,c,d,e,f,g,h,i,j,k,l) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g, toJSON h+ , toJSON i, toJSON j, toJSON k, toJSON l]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j,+ FromJSON k, FromJSON l) =>+ FromJSON (a,b,c,d,e,f,g,h,i,j,k,l) where+ parseJSON = withArray "(a,b,c,d,e,f,g,h,i,j,k,l)" $ \ary ->+ let n = JSA.length ary+ in if n /= 12+ then fail $ "cannot unpack array of length " +++ show n ++ " into a 12-tuple"+ else (,,,,,,,,,,,)+ <$> parseJSON (indexV ary 0)+ <*> parseJSON (indexV ary 1)+ <*> parseJSON (indexV ary 2)+ <*> parseJSON (indexV ary 3)+ <*> parseJSON (indexV ary 4)+ <*> parseJSON (indexV ary 5)+ <*> parseJSON (indexV ary 6)+ <*> parseJSON (indexV ary 7)+ <*> parseJSON (indexV ary 8)+ <*> parseJSON (indexV ary 9)+ <*> parseJSON (indexV ary 10)+ <*> parseJSON (indexV ary 11)+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l,+ ToJSON m) =>+ ToJSON (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ toJSON (a,b,c,d,e,f,g,h,i,j,k,l,m) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g, toJSON h+ , toJSON i, toJSON j, toJSON k, toJSON l+ , toJSON m]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j,+ FromJSON k, FromJSON l, FromJSON m) =>+ FromJSON (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ parseJSON = withArray "(a,b,c,d,e,f,g,h,i,j,k,l,m)" $ \ary ->+ let n = JSA.length ary+ in if n /= 13+ then fail $ "cannot unpack array of length " +++ show n ++ " into a 13-tuple"+ else (,,,,,,,,,,,,)+ <$> parseJSON (indexV ary 0)+ <*> parseJSON (indexV ary 1)+ <*> parseJSON (indexV ary 2)+ <*> parseJSON (indexV ary 3)+ <*> parseJSON (indexV ary 4)+ <*> parseJSON (indexV ary 5)+ <*> parseJSON (indexV ary 6)+ <*> parseJSON (indexV ary 7)+ <*> parseJSON (indexV ary 8)+ <*> parseJSON (indexV ary 9)+ <*> parseJSON (indexV ary 10)+ <*> parseJSON (indexV ary 11)+ <*> parseJSON (indexV ary 12)+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l,+ ToJSON m, ToJSON n) =>+ ToJSON (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ toJSON (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g, toJSON h+ , toJSON i, toJSON j, toJSON k, toJSON l+ , toJSON m, toJSON n]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j,+ FromJSON k, FromJSON l, FromJSON m, FromJSON n) =>+ FromJSON (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ parseJSON = withArray "(a,b,c,d,e,f,g,h,i,j,k,l,m,n)" $ \ary ->+ let n = JSA.length ary+ in if n /= 14+ then fail $ "cannot unpack array of length " +++ show n ++ " into a 14-tuple"+ else (,,,,,,,,,,,,,)+ <$> parseJSON (indexV ary 0)+ <*> parseJSON (indexV ary 1)+ <*> parseJSON (indexV ary 2)+ <*> parseJSON (indexV ary 3)+ <*> parseJSON (indexV ary 4)+ <*> parseJSON (indexV ary 5)+ <*> parseJSON (indexV ary 6)+ <*> parseJSON (indexV ary 7)+ <*> parseJSON (indexV ary 8)+ <*> parseJSON (indexV ary 9)+ <*> parseJSON (indexV ary 10)+ <*> parseJSON (indexV ary 11)+ <*> parseJSON (indexV ary 12)+ <*> parseJSON (indexV ary 13)+ {-# INLINE parseJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f,+ ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l,+ ToJSON m, ToJSON n, ToJSON o) =>+ ToJSON (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ toJSON (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = arrayValue $ arrayValueList+ [ toJSON a, toJSON b, toJSON c, toJSON d+ , toJSON e, toJSON f, toJSON g, toJSON h+ , toJSON i, toJSON j, toJSON k, toJSON l+ , toJSON m, toJSON n, toJSON o]+ {-# INLINE toJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,+ FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j,+ FromJSON k, FromJSON l, FromJSON m, FromJSON n, FromJSON o) =>+ FromJSON (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ parseJSON = withArray "(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)" $ \ary ->+ let n = JSA.length ary+ in if n /= 15+ then fail $ "cannot unpack array of length " +++ show n ++ " into a 15-tuple"+ else (,,,,,,,,,,,,,,)+ <$> parseJSON (indexV ary 0)+ <*> parseJSON (indexV ary 1)+ <*> parseJSON (indexV ary 2)+ <*> parseJSON (indexV ary 3)+ <*> parseJSON (indexV ary 4)+ <*> parseJSON (indexV ary 5)+ <*> parseJSON (indexV ary 6)+ <*> parseJSON (indexV ary 7)+ <*> parseJSON (indexV ary 8)+ <*> parseJSON (indexV ary 9)+ <*> parseJSON (indexV ary 10)+ <*> parseJSON (indexV ary 11)+ <*> parseJSON (indexV ary 12)+ <*> parseJSON (indexV ary 13)+ <*> parseJSON (indexV ary 14)+ {-# INLINE parseJSON #-}++instance ToJSON a => ToJSON (Dual a) where+ toJSON = toJSON . getDual+ {-# INLINE toJSON #-}++instance FromJSON a => FromJSON (Dual a) where+ parseJSON = fmap Dual . parseJSON+ {-# INLINE parseJSON #-}++instance ToJSON a => ToJSON (First a) where+ toJSON = toJSON . getFirst+ {-# INLINE toJSON #-}++instance FromJSON a => FromJSON (First a) where+ parseJSON = fmap First . parseJSON+ {-# INLINE parseJSON #-}++instance ToJSON a => ToJSON (Last a) where+ toJSON = toJSON . getLast+ {-# INLINE toJSON #-}++instance FromJSON a => FromJSON (Last a) where+ parseJSON = fmap Last . parseJSON+ {-# INLINE parseJSON #-}++-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@+-- and fails using @'typeMismatch' expected@ otherwise.+withObject :: String -> (Object -> Parser a) -> Value -> Parser a+withObject _ f (match -> Object obj) = f obj+withObject expected _ v = typeMismatch expected v+{-# INLINE withObject #-}++{-+-- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@+-- and fails using @'typeMismatch' expected@ otherwise.+withText :: String -> (Text -> Parser a) -> Value -> Parser a+withText _ f (String txt) = f txt+withText expected _ v = typeMismatch expected v+{-# INLINE withText #-}+-}++withJSString :: String -> (JSString -> Parser a) -> Value -> Parser a+withJSString _ f (match -> String txt) = f txt+withJSString expected _ v = typeMismatch expected v+{-# INLINE withJSString #-}++-- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@+-- and fails using @'typeMismatch' expected@ otherwise.+withArray :: String -> (JSArray -> Parser a) -> Value -> Parser a+withArray _ f (match -> Array arr) = f arr+withArray expected _ v = typeMismatch expected v+{-# INLINE withArray #-}++{-+-- | @withNumber expected f value@ applies @f@ to the 'Number' when @value@ is a 'Number'.+-- and fails using @'typeMismatch' expected@ otherwise.+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a+withNumber expected f = withScientific expected (f . scientificToNumber)+{-# INLINE withNumber #-}+{-# DEPRECATED withNumber "Use withScientific instead" #-}+-}+-- | @withScientific expected f value@ applies @f@ to the 'Double' number when @value@ is a 'Number'.+-- and fails using @'typeMismatch' expected@ otherwise.+withDouble :: String -> (Double -> Parser a) -> Value -> Parser a+withDouble _ f (match -> Number d) = f d+withDouble expected _ v = typeMismatch expected v+{-# INLINE withDouble #-}++-- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@+-- and fails using @'typeMismatch' expected@ otherwise.+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a+withBool _ f (match -> Bool arr) = f arr+withBool expected _ v = typeMismatch expected v+{-# INLINE withBool #-}++-- | Construct a 'Pair' from a key and a value.+(.=) :: ToJSON a => JSString -> a -> Pair+name .= value = (name, toJSON value)+{-# INLINE (.=) #-}++-- | Convert a value from JSON, failing if the types do not match.+fromJSON :: (FromJSON a) => Value -> Result a+fromJSON = parse parseJSON+{-# INLINE fromJSON #-}++-- | Retrieve the value associated with the given key of an 'Object'.+-- The result is 'empty' if the key is not present or the value cannot+-- be converted to the desired type.+--+-- This accessor is appropriate if the key and value /must/ be present+-- in an object for it to be valid. If the key and value are+-- optional, use '(.:?)' instead.+(.:) :: (FromJSON a) => Object -> JSString -> Parser a+obj .: key = case I.lookup key obj of+ Nothing -> fail $ "key " ++ show key ++ " not present"+ Just v -> parseJSON v+{-# INLINE (.:) #-}++-- | Retrieve the value associated with the given key of an 'Object'.+-- The result is 'Nothing' if the key is not present, or 'empty' if+-- the value cannot be converted to the desired type.+--+-- This accessor is most useful if the key and value can be absent+-- from an object without affecting its validity. If the key and+-- value are mandatory, use '(.:)' instead.+(.:?) :: (FromJSON a) => Object -> JSString -> Parser (Maybe a)+obj .:? key = case I.lookup key obj of+ Nothing -> pure Nothing+ Just v -> parseJSON v+{-# INLINE (.:?) #-}++-- | Helper for use in combination with '.:?' to provide default+-- values for optional JSON object fields.+--+-- This combinator is most useful if the key and value can be absent+-- from an object without affecting its validity and we know a default+-- value to assign in that case. If the key and value are mandatory,+-- use '(.:)' instead.+--+-- Example usage:+--+-- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\"+-- v2 <- o '.:' \"mandatory_field\"+-- v3 <- o '.:?' \"opt_field2\"+-- @+(.!=) :: Parser (Maybe a) -> a -> Parser a+pmval .!= val = fromMaybe val <$> pmval+{-# INLINE (.!=) #-}++-- | Fail parsing due to a type mismatch, with a descriptive message.+typeMismatch :: String -- ^ The name of the type you are trying to parse.+ -> Value -- ^ The actual value encountered.+ -> Parser a+typeMismatch expected actual =+ fail $ "when expecting a " ++ expected ++ ", encountered " ++ name +++ " instead"+ where+ name = case match actual of+ Object _ -> "Object"+ Array _ -> "Array"+ String _ -> "String"+ Number _ -> "Number"+ Bool _ -> "Boolean"+ Null -> "Null"++realFloatToJSON :: RealFloat a => a -> Value+realFloatToJSON d+ | isNaN d || isInfinite d = nullValue+ | otherwise = doubleValue (realToFrac d)+{-# INLINE realFloatToJSON #-}++scientificToNumber :: Scientific -> Number+scientificToNumber s+ | e < 0 = D $ Scientific.toRealFloat s+ | otherwise = I $ c * 10 ^ e+ where+ e = Scientific.base10Exponent s+ c = Scientific.coefficient s+{-# INLINE scientificToNumber #-}++parseRealFloat :: RealFloat a => String -> Value -> Parser a+parseRealFloat _ (match -> Number d) = pure $ realToFrac d+parseRealFloat _ (match -> Null) = pure (0/0)+parseRealFloat expected v = typeMismatch expected v+{-# INLINE parseRealFloat #-}++parseIntegral :: Integral a => String -> Value -> Parser a+parseIntegral expected = withDouble expected $ pure . floor+{-# INLINE parseIntegral #-}++arrayToValueList :: JSArray -> [Value]+arrayToValueList x = unsafeCoerce (JSA.toList x) -- fixme should me normal coerce+{-# INLINE arrayToValueList #-}
+ JavaScript/JSON/Types/Internal.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, EmptyDataDecls,+ DeriveDataTypeable, GHCForeignImportPrim, DataKinds, KindSignatures,+ PolyKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances,+ UnboxedTuples, MagicHash, UnliftedFFITypes+ #-}++module JavaScript.JSON.Types.Internal+ ( -- * Core JSON types+ SomeValue(..), Value, MutableValue+ , SomeValue'(..), Value', MutableValue'+ , MutableValue, MutableValue'+ , emptyArray, isEmptyArray+ , Pair+ , Object, MutableObject+ , objectProperties, objectPropertiesIO+ , objectAssocs, objectAssocsIO+ , Lookup(..), IOLookup(..)+ , emptyObject+ , match+ , arrayValue, stringValue, doubleValue, nullValue, boolValue, objectValue+ , arrayValueList, indexV+ {- fixme implement freezing / thawing+ , freeze, unsafeFreeze+ , thaw, unsafeThaw+ -}+ -- * Type conversion+ , Parser+ , Result(..)+ , parse+ , parseEither+ , parseMaybe+ , modifyFailure+ , encode+ -- * Constructors and accessors+ , object++ -- * Generic and TH encoding configuration+ , Options(..)+ , SumEncoding(..)+ , defaultOptions+ , defaultTaggedObject+ + -- * Used for changing CamelCase names into something else.+ , camelTo+ -- * Other types+ , DotNetTime(..)+ ) where++import Data.Aeson.Types+ ( Parser, Result(..)+ , parse, parseEither, parseMaybe, modifyFailure+ , Options(..), SumEncoding(..), defaultOptions, defaultTaggedObject+ , camelTo+ , DotNetTime(..)+ )++import Prelude hiding (lookup)++import Control.DeepSeq+import Control.Exception++import Data.Coerce+import Data.Data+import qualified Data.JSString as JSS+import Data.JSString.Internal.Type (JSString(..))+import Data.Maybe (fromMaybe)+import Data.Typeable++import qualified GHC.Exts as Exts+import GHC.Types (IO(..))++import qualified GHCJS.Foreign as F+import GHCJS.Internal.Types+import GHCJS.Types+import qualified GHCJS.Prim.Internal.Build as IB++import qualified JavaScript.Array as A+import qualified JavaScript.Array.Internal as AI++import Unsafe.Coerce++data JSONException = UnknownKey+ deriving (Show, Typeable)++instance Exception JSONException++-- any JSON value+newtype SomeValue (m :: MutabilityType s) =+ SomeValue JSVal deriving (Typeable)+type Value = SomeValue Immutable+type MutableValue = SomeValue Mutable+instance NFData (SomeValue (m :: MutabilityType s)) where+ rnf (SomeValue v) = rnf v++-- a dictionary (object)+newtype SomeObject (m :: MutabilityType s) =+ SomeObject JSVal deriving (Typeable)+type Object = SomeObject Immutable+type MutableObject = SomeObject Mutable+instance NFData (SomeObject (m :: MutabilityType s)) where+ rnf (SomeObject v) = rnf v++{-+objectFromAssocs :: [(JSString, Value)] -> Object+objectFromAssocs xs = rnf xs `seq` js_objectFromAssocs (unsafeCoerce xs)+{-# INLINE objectFromAssocs #-}+-}++objectProperties :: Object -> AI.JSArray+objectProperties o = js_objectPropertiesPure o+{-# INLINE objectProperties #-}++objectPropertiesIO :: SomeObject o -> IO AI.JSArray+objectPropertiesIO o = js_objectProperties o+{-# INLINE objectPropertiesIO #-}++objectAssocs :: Object -> [(JSString, Value)]+objectAssocs o = unsafeCoerce (js_listAssocsPure o)+{-# INLINE objectAssocs #-}++objectAssocsIO :: SomeObject m -> IO [(JSString, Value)]+objectAssocsIO o = IO $ \s -> case js_listAssocs o s of+ (# s', r #) -> (# s', unsafeCoerce r #)+{-# INLINE objectAssocsIO #-}++type Pair = (JSString, Value)+type MutablePair = (JSString, MutableValue)++data SomeValue' (m :: MutabilityType s)+ = Object !(SomeObject m)+ | Array !(AI.SomeJSArray m)+ | String !JSString+ | Number !Double+ | Bool !Bool+ | Null+ deriving (Typeable)++type Value' = SomeValue' Immutable+type MutableValue' = SomeValue' Mutable++-- -----------------------------------------------------------------------------+-- immutable lookup++class Lookup k a where+ (!) :: k -> a -> Value -- ^ throws when result is not a JSON value+ lookup :: k -> a -> Maybe Value -- ^ returns Nothing when result is not a JSON value+-- fixme more optimized matching+-- lookup' :: k -> a -> Maybe Value' -- ^ returns Nothing when result is not a JSON value++instance Lookup JSString Object where+ p ! d = fromMaybe (throw UnknownKey) (lookup p d)+ lookup p d = let v = js_lookupDictPure p d+ in if isUndefined v then Nothing else Just (SomeValue v)++instance Lookup JSString Value where+ p ! d = fromMaybe (throw UnknownKey) (lookup p d)+ lookup p d = let v = js_lookupDictPureSafe p d+ in if isUndefined v then Nothing else Just (SomeValue v)++instance Lookup Int A.JSArray where+ i ! a = fromMaybe (throw UnknownKey) (lookup i a)+ lookup i a = let v = js_lookupArrayPure i a+ in if isUndefined v then Nothing else Just (SomeValue v)+ +instance Lookup Int Value where+ i ! a = fromMaybe (throw UnknownKey) (lookup i a)+ lookup i a = let v = js_lookupArrayPureSafe i a+ in if isUndefined v then Nothing else Just (SomeValue v)++-- -----------------------------------------------------------------------------+-- mutable lookup++class IOLookup k a where+ (^!) :: k -> a -> IO MutableValue -- ^ throws when result is not a JSON value+ lookupIO :: k -> a -> IO (Maybe MutableValue) -- ^ returns Nothing when result is not a JSON value+ lookupIO' :: k -> a -> IO (Maybe MutableValue') -- ^ returns Nothing when result is not a JSON value++-- -----------------------------------------------------------------------------++match :: SomeValue m -> SomeValue' m+match (SomeValue v) =+ case F.jsonTypeOf v of+ F.JSONNull -> Null+ F.JSONBool -> Bool (js_jsvalToBool v)+ F.JSONInteger -> Number (js_jsvalToDouble v)+ F.JSONFloat -> Number (js_jsvalToDouble v)+ F.JSONString -> String (JSString v)+ F.JSONArray -> Array (AI.SomeJSArray v)+ F.JSONObject -> Object (SomeObject v)+{-# INLINE match #-}++emptyArray :: Value+emptyArray = js_emptyArray+{-# INLINE emptyArray #-}++isEmptyArray :: Value -> Bool+isEmptyArray v = js_isEmptyArray v+{-# INLINE isEmptyArray #-}++emptyObject :: Object+emptyObject = js_emptyObject+{-# INLINE emptyObject #-}++object :: [Pair] -> Object+object [] = js_emptyObject+object xs = SomeObject (IB.buildObjectI $ coerce xs)+{-# INLINE object #-}++freeze :: MutableValue -> IO Value+freeze v = js_clone v+{-# INLINE freeze #-}++unsafeFreeze :: MutableValue -> IO Value+unsafeFreeze (SomeValue v) = pure (SomeValue v)+{-# INLINE unsafeFreeze #-}++thaw :: Value -> IO MutableValue+thaw v = js_clone v+{-# INLINE thaw #-}++unsafeThaw :: Value -> IO MutableValue+unsafeThaw (SomeValue v) = pure (SomeValue v)+{-# INLINE unsafeThaw #-}++-- -----------------------------------------------------------------------------+-- smart constructors++arrayValue :: AI.JSArray -> Value+arrayValue (AI.SomeJSArray a) = SomeValue a+{-# INLINE arrayValue #-}++stringValue :: JSString -> Value+stringValue (JSString x) = SomeValue x+{-# INLINE stringValue #-}++doubleValue :: Double -> Value+doubleValue d = SomeValue (js_doubleToJSVal d)+{-# INLINE doubleValue #-}++boolValue :: Bool -> Value+boolValue True = js_trueValue+boolValue False = js_falseValue+{-# INLINE boolValue #-}++nullValue :: Value+nullValue = SomeValue F.jsNull++arrayValueList :: [Value] -> AI.JSArray+arrayValueList xs = A.fromList (coerce xs)+{-# INLINE arrayValueList #-}++indexV :: AI.JSArray -> Int -> Value+indexV a i = SomeValue (AI.index i a)+{-# INLINE indexV #-}++objectValue :: Object -> Value+objectValue (SomeObject o) = SomeValue o+{-# INLINE objectValue #-}++encode :: Value -> JSString+encode v = js_encode v+{-# INLINE encode #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$r = [];" js_emptyArray :: Value+foreign import javascript unsafe+ "$r = {};" js_emptyObject :: Object+foreign import javascript unsafe+ "$1.length === 0" js_isEmptyArray :: Value -> Bool++foreign import javascript unsafe+ "$r = true;" js_trueValue :: Value+foreign import javascript unsafe+ "$r = false;" js_falseValue :: Value++-- -----------------------------------------------------------------------------+-- types must be checked before using these conversions++foreign import javascript unsafe+ "$r = $1;" js_jsvalToDouble :: JSVal -> Double+foreign import javascript unsafe+ "$r = $1;" js_jsvalToBool :: JSVal -> Bool++-- -----------------------------------------------------------------------------+-- various lookups++foreign import javascript unsafe+ "$2[$1]"+ js_lookupDictPure :: JSString -> Object -> JSVal++foreign import javascript unsafe+ "typeof($2)==='object'?$2[$1]:undefined"+ js_lookupDictPureSafe :: JSString -> Value -> JSVal++foreign import javascript unsafe+ "$2[$1]" js_lookupArrayPure :: Int -> A.JSArray -> JSVal+foreign import javascript unsafe+ "h$isArray($2) ? $2[$1] : undefined"+ js_lookupArrayPureSafe :: Int -> Value -> JSVal+foreign import javascript unsafe+ "$r = $1;"+ js_doubleToJSVal :: Double -> JSVal++foreign import javascript unsafe+ "JSON.decode(JSON.encode($1))"+ js_clone :: SomeValue m0 -> IO (SomeValue m1)++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "h$allProps"+ js_objectPropertiesPure :: Object -> AI.JSArray+foreign import javascript unsafe+ "h$allProps"+ js_objectProperties :: SomeObject m -> IO AI.JSArray++foreign import javascript unsafe+ "h$listAssocs"+ js_listAssocsPure :: Object -> Exts.Any -- [(JSString, Value)]+foreign import javascript unsafe+ "h$listAssocs"+ js_listAssocs :: SomeObject m -> Exts.State# s -> (# Exts.State# s, Exts.Any {- [(JSString, Value)] -} #)++foreign import javascript unsafe+ "JSON.stringify($1)"+ js_encode :: Value -> JSString
+ JavaScript/Number.hs view
@@ -0,0 +1,2 @@+module JavaScript.Number where+
+ JavaScript/Object.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE UnboxedTuples #-}++module JavaScript.Object ( Object+ , create+ , getProp, unsafeGetProp+ , setProp, unsafeSetProp+ , allProps, listProps+ , isInstanceOf+ ) where++++import Data.JSString++import qualified JavaScript.Array as A++import qualified JavaScript.Array.Internal as AI+import JavaScript.Object.Internal (Object(..))++import JavaScript.Object.Internal -- as I++import GHCJS.Types++{-+-- | create an empty object+create :: IO Object+create = fmap Object I.create+{-# INLINE create #-}++allProps :: Object -> IO (JSArray JSString)+allProps (Object o) = fmap AI.JSArray (I.allProps o)+{-# INLINE allProps #-}++listProps :: Object -> IO [JSString]+listProps (Object o) = I.listProps o+{-# INLINE listProps #-}++{- | get a property from an object. If accessing the property results in+ an exception, the exception is converted to a JSException. Since exception+ handling code prevents some optimizations in some JS engines, you may want+ to use unsafeGetProp instead+ -}+getProp :: JSString -> Object -> IO (JSVal a)+getProp p (Object o) = I.getProp p o+{-# INLINE getProp #-}++unsafeGetProp :: JSString -> Object -> IO (JSVal a)+unsafeGetProp p (Object o) = I.unsafeGetProp p o+{-# INLINE unsafeGetProp #-}++setProp :: JSString -> JSVal a -> Object -> IO ()+setProp p v (Object o) = I.setProp p v o+{-# INLINE setProp #-}++unsafeSetProp :: JSString -> JSVal a -> Object -> IO ()+unsafeSetProp p v (Object o) = I.unsafeSetProp p v o+{-# INLINE unsafeSetProp #-}++isInstanceOf :: Object -> JSVal a -> Bool+isInstanceOf (Object o) s = I.isInstanceOf o s+{-# INLINE isInstanceOf #-}+-}++-- -----------------------------------------------------------------------------+{-+foreign import javascript safe "$2[$1]"+ js_getProp :: JSString -> JSVal a -> IO (JSVal b)+foreign import javascript unsafe "$2[$1]"+ js_unsafeGetProp :: JSString -> JSVal a -> IO (JSVal b)+foreign import javascript safe "$3[$1] = $2"+ js_setProp :: JSString -> JSVal a -> JSVal b -> IO ()+foreign import javascript unsafe "$3[$1] = $2"+ js_unsafeSetProp :: JSString -> JSVal a -> JSVal b -> IO ()+foreign import javascript unsafe "$1 instanceof $2"+ js_isInstanceOf :: Object -> JSVal a -> Bool+foreign import javascript unsafe "h$allProps"+ js_allProps :: Object -> IO (JSArray JSString)+foreign import javascript unsafe "h$listProps"+ js_listProps :: Object -> (# [JSString] #)+-}
+ JavaScript/Object/Internal.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE UnliftedFFITypes #-}++module JavaScript.Object.Internal+ ( Object(..)+ , create+ , allProps+ , listProps+ , getProp+ , unsafeGetProp+ , setProp+ , unsafeSetProp+ , isInstanceOf+ ) where++import Data.JSString+import Data.Typeable++import qualified GHCJS.Prim as Prim+import GHCJS.Types++import qualified JavaScript.Array as JA+import JavaScript.Array.Internal (JSArray, SomeJSArray(..))++import Unsafe.Coerce+import qualified GHC.Exts as Exts++newtype Object = Object JSVal deriving (Typeable)+instance IsJSVal Object++-- | create an empty object+create :: IO Object+create = js_create+{-# INLINE create #-}++allProps :: Object -> IO JSArray+allProps o = js_allProps o+{-# INLINE allProps #-}++listProps :: Object -> IO [JSString]+listProps o = unsafeCoerce (js_listProps o)+{-# INLINE listProps #-}++{- | get a property from an object. If accessing the property results in+ an exception, the exception is converted to a JSException. Since exception+ handling code prevents some optimizations in some JS engines, you may want+ to use unsafeGetProp instead+ -}+getProp :: JSString -> Object -> IO JSVal+getProp p o = js_getProp p o+{-# INLINE getProp #-}++unsafeGetProp :: JSString -> Object -> IO JSVal+unsafeGetProp p o = js_unsafeGetProp p o+{-# INLINE unsafeGetProp #-}++setProp :: JSString -> JSVal -> Object -> IO ()+setProp p v o = js_setProp p v o+{-# INLINE setProp #-}++unsafeSetProp :: JSString -> JSVal -> Object -> IO ()+unsafeSetProp p v o = js_unsafeSetProp p v o+{-# INLINE unsafeSetProp #-}++isInstanceOf :: Object -> JSVal -> Bool+isInstanceOf o s = js_isInstanceOf o s+{-# INLINE isInstanceOf #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe "$r = {};"+ js_create :: IO Object+foreign import javascript safe "$2[$1]"+ js_getProp :: JSString -> Object -> IO JSVal+foreign import javascript unsafe "$2[$1]"+ js_unsafeGetProp :: JSString -> Object -> IO JSVal+foreign import javascript safe "$3[$1] = $2"+ js_setProp :: JSString -> JSVal -> Object -> IO ()+foreign import javascript unsafe "$3[$1] = $2"+ js_unsafeSetProp :: JSString -> JSVal -> Object -> IO ()+foreign import javascript unsafe "$1 instanceof $2"+ js_isInstanceOf :: Object -> JSVal -> Bool+foreign import javascript unsafe "h$allProps"+ js_allProps :: Object -> IO JSArray+foreign import javascript unsafe "h$listProps"+ js_listProps :: Object -> IO Exts.Any -- [JSString]
+ JavaScript/RegExp.hs view
@@ -0,0 +1,5 @@+module JavaScript.RegExp+ ( module Data.JSString.RegExp+ ) where++import Data.JSString.RegExp
+ JavaScript/TypedArray.hs view
@@ -0,0 +1,19 @@+module JavaScript.TypedArray+ ( TypedArray(..)+ , Int8Array, Int16Array, Int32Array+ , Uint8Array, Uint16Array, Uint32Array+ , Uint8ClampedArray, Float32Array, Float64Array+ , length+ , byteLength+ , byteOffset+ , buffer+ , subarray+ , set+ , unsafeSet+ ) where++import Prelude ()++import JavaScript.TypedArray.Internal+import JavaScript.TypedArray.Internal.Types+
+ JavaScript/TypedArray/ArrayBuffer.hs view
@@ -0,0 +1,48 @@+module JavaScript.TypedArray.ArrayBuffer+ ( ArrayBuffer+ , MutableArrayBuffer+ , freeze, unsafeFreeze+ , thaw, unsafeThaw+ , byteLength+ ) where++import JavaScript.TypedArray.ArrayBuffer.Internal++import GHC.Exts+import GHC.Types++create :: Int -> IO MutableArrayBuffer+create n = fmap SomeArrayBuffer (IO (js_create n))+{-# INLINE create #-}++{- | Create an immutable 'ArrayBuffer' by copying a 'MutableArrayBuffer' -}+freeze :: MutableArrayBuffer -> IO ArrayBuffer+freeze (SomeArrayBuffer b) = fmap SomeArrayBuffer (IO (js_slice1 0 b))+{-# INLINE freeze #-}++{- | Create an immutable 'ArrayBuffer' from a 'MutableArrayBuffer' without+ copying. The result shares the buffer with the argument, not modify+ the data in the 'MutableArrayBuffer' after freezing+ -}+unsafeFreeze :: MutableArrayBuffer -> IO ArrayBuffer+unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b)+{-# INLINE unsafeFreeze #-}++{- | Create a 'MutableArrayBuffer' by copying an immutable 'ArrayBuffer' -}+thaw :: ArrayBuffer -> IO MutableArrayBuffer+thaw (SomeArrayBuffer b) = fmap SomeArrayBuffer (IO (js_slice1 0 b))+{-# INLINE thaw #-}++unsafeThaw :: ArrayBuffer -> IO MutableArrayBuffer+unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b)+{-# INLINE unsafeThaw #-}++slice :: Int -> Maybe Int -> SomeArrayBuffer any -> SomeArrayBuffer any+slice begin (Just end) b = js_slice_imm begin end b+slice begin _ b = js_slice1_imm begin b+{-# INLINE slice #-}++byteLength :: SomeArrayBuffer any -> Int+byteLength b = js_byteLength b+{-# INLINE byteLength #-}+
+ JavaScript/TypedArray/ArrayBuffer/Internal.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}++module JavaScript.TypedArray.ArrayBuffer.Internal where++import GHCJS.Types++import GHCJS.Internal.Types+import GHCJS.Marshal.Pure++import GHC.Exts (State#)++import Data.Typeable++newtype SomeArrayBuffer (a :: MutabilityType s) =+ SomeArrayBuffer JSVal deriving Typeable+instance IsJSVal (SomeArrayBuffer m)++type ArrayBuffer = SomeArrayBuffer Immutable+type MutableArrayBuffer = SomeArrayBuffer Mutable+type STArrayBuffer s = SomeArrayBuffer (STMutable s)++instance PToJSVal MutableArrayBuffer where+ pToJSVal (SomeArrayBuffer b) = b+instance PFromJSVal MutableArrayBuffer where+ pFromJSVal = SomeArrayBuffer++-- ----------------------------------------------------------------------------++foreign import javascript unsafe+ "$1.byteLength" js_byteLength :: SomeArrayBuffer any -> Int+foreign import javascript unsafe+ "new ArrayBuffer($1)" js_create :: Int -> State# s -> (# State# s, JSVal #)+foreign import javascript unsafe+ "$2.slice($1)" js_slice1 :: Int -> JSVal -> State# s -> (# State# s, JSVal #)++-- ----------------------------------------------------------------------------+-- immutable non-IO slice++foreign import javascript unsafe+ "$2.slice($1)" js_slice1_imm :: Int -> SomeArrayBuffer any -> SomeArrayBuffer any+foreign import javascript unsafe+ "$3.slice($1,$2)" js_slice_imm :: Int -> Int -> SomeArrayBuffer any -> SomeArrayBuffer any
+ JavaScript/TypedArray/ArrayBuffer/ST.hs view
@@ -0,0 +1,35 @@+module JavaScript.TypedArray.ArrayBuffer.ST+ ( STArrayBuffer+ , freeze, unsafeFreeze+ , thaw, unsafeThaw+ ) where++import Control.Monad.ST++import GHC.Types+import GHC.Exts+import GHC.ST++import JavaScript.TypedArray.ArrayBuffer.Internal++create :: Int -> ST s (STArrayBuffer s)+create n = fmap SomeArrayBuffer $ ST (js_create n)+{-# INLINE create #-}++freeze :: STArrayBuffer s -> ST s ArrayBuffer+freeze (SomeArrayBuffer b) = fmap SomeArrayBuffer (ST (js_slice1 0 b))+{-# INLINE freeze #-}++unsafeFreeze :: STArrayBuffer s -> ST s ArrayBuffer+unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b)+{-# INLINE unsafeFreeze #-}++{- | Create an 'STArrayBuffer' by copying an immutable 'ArrayBuffer' -}+thaw :: ArrayBuffer -> ST s (STArrayBuffer s)+thaw (SomeArrayBuffer b) = fmap SomeArrayBuffer (ST (js_slice1 0 b))+{-# INLINE thaw #-}++unsafeThaw :: ArrayBuffer -> ST s (STArrayBuffer s)+unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b)+{-# INLINE unsafeThaw #-}+
+ JavaScript/TypedArray/DataView.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE CPP #-}+module JavaScript.TypedArray.DataView+ ( DataView+ , MutableDataView+ , dataView+-- , mutableDataView+ , freeze, unsafeFreeze+ , thaw, unsafeThaw+ -- * reading an immutable dataview+ , getInt8, unsafeGetInt8+ , getInt16LE, getInt16BE, unsafeGetInt16LE, unsafeGetInt16BE+ , getInt32LE, getInt32BE, unsafeGetInt32LE, unsafeGetInt32BE+ , getUint8, unsafeGetUint8+ , getUint16LE, getUint16BE, unsafeGetUint16LE, unsafeGetUint16BE+ , getUint32LE, getUint32BE, unsafeGetUint32LE, unsafeGetUint32BE+ , getFloat32LE, getFloat32BE, unsafeGetFloat32LE, unsafeGetFloat32BE+ , getFloat64LE, getFloat64BE, unsafeGetFloat64LE, unsafeGetFloat64BE+ -- * reading a mutable dataview+ , readInt8, unsafeReadInt8+ , readInt16LE, readInt16BE, unsafeReadInt16LE, unsafeReadInt16BE+ , readInt32LE, readInt32BE, unsafeReadInt32LE, unsafeReadInt32BE+ , readUint8, unsafeReadUint8+ , readUint16LE, readUint16BE, unsafeReadUint16LE, unsafeReadUint16BE+ , readUint32LE, readUint32BE, unsafeReadUint32LE, unsafeReadUint32BE+ , readFloat32LE, readFloat32BE, unsafeReadFloat32LE, unsafeReadFloat32BE+ , readFloat64LE, readFloat64BE, unsafeReadFloat64LE, unsafeReadFloat64BE+ -- * writing to a mutable dataview+ , writeInt8, unsafeWriteInt8+ , writeInt16LE, writeInt16BE, unsafeWriteInt16LE, unsafeWriteInt16BE+ , writeInt32LE, writeInt32BE, unsafeWriteInt32LE, unsafeWriteInt32BE+ , writeUint8, unsafeWriteUint8+ , writeUint16LE, writeUint16BE, unsafeWriteUint16LE, unsafeWriteUint16BE+ , writeUint32LE, writeUint32BE, unsafeWriteUint32LE, unsafeWriteUint32BE+ , writeFloat32LE, writeFloat32BE, unsafeWriteFloat32LE, unsafeWriteFloat32BE+ , writeFloat64LE, writeFloat64BE, unsafeWriteFloat64LE, unsafeWriteFloat64BE+ ) where++import GHC.Types (IO(..))++import Data.Int+import Data.Word++import GHCJS.Prim++import JavaScript.TypedArray.ArrayBuffer.Internal+ ( SomeArrayBuffer(..), ArrayBuffer, MutableArrayBuffer )+import qualified JavaScript.TypedArray.ArrayBuffer as A+import JavaScript.TypedArray.DataView.Internal+ ( SomeDataView(..), DataView, MutableDataView )+import qualified JavaScript.TypedArray.DataView.Internal as I++{- | Create a 'DataView' for the whole 'ArrayBuffer' -}+dataView :: SomeArrayBuffer any -> SomeDataView any+dataView (SomeArrayBuffer b) = SomeDataView (I.js_dataView1 b)+{-# INLINE dataView #-}++{- | Create a 'DataView' for part of an 'ArrayBuffer'+ Throws a `JSException' if the range specified by the+ offset and length exceeds the size of the buffer+ -}+dataView' :: Int -- ^ start in bytes+ -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing'+ -> SomeArrayBuffer any -- ^ buffer to view+ -> SomeDataView any+dataView' byteOffset mbyteLength (SomeArrayBuffer b) =+ case mbyteLength of+ Nothing -> I.js_dataView2 byteOffset b+ Just byteLength -> I.js_dataView byteOffset byteLength b+{-# INLINE dataView' #-}++{- | Create a 'DataView' for part of an 'ArrayBuffer'.+ If the range specified by the offset and length exceeds the size+ off the buffer, the resulting exception from the underlying call+ kills the Haskell thread.+ -}+unsafeDataView' :: Int -- ^ start in bytes+ -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing'+ -> SomeArrayBuffer any -- ^ buffer to view+ -> SomeDataView any+unsafeDataView' byteOffset mbyteLength (SomeArrayBuffer b) =+ case mbyteLength of+ Nothing -> I.js_dataView2 byteOffset b+ Just byteLength -> I.js_dataView byteOffset byteLength b+{-# INLINE unsafeDataView' #-}++thaw :: DataView -> IO MutableDataView+thaw d = I.js_cloneDataView d+{-# INLINE thaw #-}++unsafeThaw :: DataView -> IO MutableDataView+unsafeThaw (SomeDataView d) = return (SomeDataView d)+{-# INLINE unsafeThaw #-}++freeze :: MutableDataView -> IO DataView+freeze d = I.js_cloneDataView d+{-# INLINE freeze #-}++unsafeFreeze :: MutableDataView -> IO DataView+unsafeFreeze (SomeDataView d) = return (SomeDataView d)+{-# INLINE unsafeFreeze #-}++-- ----------------------------------------------------------------------------+-- immutable getters++getInt8, unsafeGetInt8 :: Int -> DataView -> Int8+getInt8 idx dv = I.js_i_getInt8 idx dv+unsafeGetInt8 idx dv = I.js_i_unsafeGetInt8 idx dv+{-# INLINE getInt8 #-}++getUint8, unsafeGetUint8 :: Int -> DataView -> Word8+getUint8 idx dv = I.js_i_getUint8 idx dv+unsafeGetUint8 idx dv = I.js_i_unsafeGetUint8 idx dv+{-# INLINE getUint8 #-}++getInt16LE, getInt16BE, unsafeGetInt16LE, unsafeGetInt16BE+ :: Int -> DataView -> Int16+getInt16LE idx dv = I.js_i_getInt16LE idx dv+getInt16BE idx dv = I.js_i_getInt16BE idx dv+unsafeGetInt16LE idx dv = I.js_i_unsafeGetInt16LE idx dv+unsafeGetInt16BE idx dv = I.js_i_unsafeGetInt16BE idx dv+{-# INLINE getInt16LE #-}+{-# INLINE getInt16BE #-}+{-# INLINE unsafeGetInt16LE #-}+{-# INLINE unsafeGetInt16BE #-}++getUint16LE, getUint16BE, unsafeGetUint16LE, unsafeGetUint16BE+ :: Int -> DataView -> Word16+getUint16LE idx dv = I.js_i_getUint16LE idx dv+getUint16BE idx dv = I.js_i_getUint16BE idx dv+unsafeGetUint16LE idx dv = I.js_i_unsafeGetUint16LE idx dv+unsafeGetUint16BE idx dv = I.js_i_unsafeGetUint16BE idx dv+{-# INLINE getUint16LE #-}+{-# INLINE getUint16BE #-}+{-# INLINE unsafeGetUint16LE #-}+{-# INLINE unsafeGetUint16BE #-}++getInt32LE, getInt32BE, unsafeGetInt32LE, unsafeGetInt32BE+ :: Int -> DataView -> Int+getInt32LE idx dv = I.js_i_getInt32LE idx dv+getInt32BE idx dv = I.js_i_getInt32BE idx dv+unsafeGetInt32LE idx dv = I.js_i_unsafeGetInt32LE idx dv+unsafeGetInt32BE idx dv = I.js_i_unsafeGetInt32BE idx dv+{-# INLINE getInt32LE #-}+{-# INLINE getInt32BE #-}+{-# INLINE unsafeGetInt32LE #-}+{-# INLINE unsafeGetInt32BE #-}++getUint32LE, getUint32BE, unsafeGetUint32LE, unsafeGetUint32BE+ :: Int -> DataView -> Word+getUint32LE idx dv = I.js_i_getUint32LE idx dv+getUint32BE idx dv = I.js_i_getUint32BE idx dv+unsafeGetUint32LE idx dv = I.js_i_unsafeGetUint32LE idx dv+unsafeGetUint32BE idx dv = I.js_i_unsafeGetUint32BE idx dv+{-# INLINE getUint32LE #-}+{-# INLINE getUint32BE #-}+{-# INLINE unsafeGetUint32LE #-}+{-# INLINE unsafeGetUint32BE #-}++getFloat32LE, getFloat32BE, unsafeGetFloat32LE, unsafeGetFloat32BE+ :: Int -> DataView -> Double+getFloat32LE idx dv = I.js_i_getFloat32LE idx dv+getFloat32BE idx dv = I.js_i_getFloat32BE idx dv+unsafeGetFloat32LE idx dv = I.js_i_unsafeGetFloat32LE idx dv+unsafeGetFloat32BE idx dv = I.js_i_unsafeGetFloat32BE idx dv+{-# INLINE getFloat32LE #-}+{-# INLINE getFloat32BE #-}+{-# INLINE unsafeGetFloat32LE #-}+{-# INLINE unsafeGetFloat32BE #-}++getFloat64LE, getFloat64BE, unsafeGetFloat64LE, unsafeGetFloat64BE+ :: Int -> DataView -> Double+getFloat64LE idx dv = I.js_i_getFloat64LE idx dv+getFloat64BE idx dv = I.js_i_getFloat64BE idx dv+unsafeGetFloat64LE idx dv = I.js_i_unsafeGetFloat64LE idx dv+unsafeGetFloat64BE idx dv = I.js_i_unsafeGetFloat64BE idx dv+{-# INLINE getFloat64LE #-}+{-# INLINE getFloat64BE #-}+{-# INLINE unsafeGetFloat64LE #-}+{-# INLINE unsafeGetFloat64BE #-}++-- ----------------------------------------------------------------------------+-- mutable getters++readInt8, unsafeReadInt8 :: Int -> MutableDataView -> IO Int8+readInt8 idx dv = IO (I.js_m_getInt8 idx dv)+unsafeReadInt8 idx dv = IO (I.js_m_unsafeGetInt8 idx dv)+{-# INLINE readInt8 #-}++readUint8, unsafeReadUint8 :: Int -> MutableDataView -> IO Word8+readUint8 idx dv = IO (I.js_m_getUint8 idx dv)+unsafeReadUint8 idx dv = IO (I.js_m_unsafeGetUint8 idx dv)+{-# INLINE readUint8 #-}++readInt16LE, readInt16BE, unsafeReadInt16LE, unsafeReadInt16BE+ :: Int -> MutableDataView -> IO Int16+readInt16LE idx dv = IO (I.js_m_getInt16LE idx dv)+readInt16BE idx dv = IO (I.js_m_getInt16BE idx dv)+unsafeReadInt16LE idx dv = IO (I.js_m_unsafeGetInt16LE idx dv)+unsafeReadInt16BE idx dv = IO (I.js_m_unsafeGetInt16BE idx dv)+{-# INLINE readInt16LE #-}+{-# INLINE readInt16BE #-}+{-# INLINE unsafeReadInt16LE #-}+{-# INLINE unsafeReadInt16BE #-}++readUint16LE, readUint16BE, unsafeReadUint16LE, unsafeReadUint16BE+ :: Int -> MutableDataView -> IO Word16+readUint16LE idx dv = IO (I.js_m_getUint16LE idx dv)+readUint16BE idx dv = IO (I.js_m_getUint16BE idx dv)+unsafeReadUint16LE idx dv = IO (I.js_m_unsafeGetUint16LE idx dv)+unsafeReadUint16BE idx dv = IO (I.js_m_unsafeGetUint16BE idx dv)+{-# INLINE readUint16LE #-}+{-# INLINE readUint16BE #-}+{-# INLINE unsafeReadUint16LE #-}+{-# INLINE unsafeReadUint16BE #-}++readInt32LE, readInt32BE, unsafeReadInt32LE, unsafeReadInt32BE+ :: Int -> MutableDataView -> IO Int+readInt32LE idx dv = IO (I.js_m_getInt32LE idx dv)+readInt32BE idx dv = IO (I.js_m_getInt32BE idx dv)+unsafeReadInt32LE idx dv = IO (I.js_m_unsafeGetInt32LE idx dv)+unsafeReadInt32BE idx dv = IO (I.js_m_unsafeGetInt32BE idx dv)+{-# INLINE readInt32LE #-}+{-# INLINE readInt32BE #-}+{-# INLINE unsafeReadInt32LE #-}+{-# INLINE unsafeReadInt32BE #-}++readUint32LE, readUint32BE, unsafeReadUint32LE, unsafeReadUint32BE+ :: Int -> MutableDataView -> IO Word+readUint32LE idx dv = IO (I.js_m_getUint32LE idx dv)+readUint32BE idx dv = IO (I.js_m_getUint32BE idx dv)+unsafeReadUint32LE idx dv = IO (I.js_m_unsafeGetUint32LE idx dv)+unsafeReadUint32BE idx dv = IO (I.js_m_unsafeGetUint32BE idx dv)+{-# INLINE readUint32LE #-}+{-# INLINE readUint32BE #-}+{-# INLINE unsafeReadUint32LE #-}+{-# INLINE unsafeReadUint32BE #-}++readFloat32LE, readFloat32BE, unsafeReadFloat32LE, unsafeReadFloat32BE+ :: Int -> MutableDataView -> IO Double+readFloat32LE idx dv = IO (I.js_m_getFloat32LE idx dv)+readFloat32BE idx dv = IO (I.js_m_getFloat32BE idx dv)+unsafeReadFloat32LE idx dv = IO (I.js_m_unsafeGetFloat32LE idx dv)+unsafeReadFloat32BE idx dv = IO (I.js_m_unsafeGetFloat32BE idx dv)+{-# INLINE readFloat32LE #-}+{-# INLINE readFloat32BE #-}+{-# INLINE unsafeReadFloat32LE #-}+{-# INLINE unsafeReadFloat32BE #-}++readFloat64LE, readFloat64BE, unsafeReadFloat64LE, unsafeReadFloat64BE+ :: Int -> MutableDataView -> IO Double+readFloat64LE idx dv = IO (I.js_m_getFloat64LE idx dv)+readFloat64BE idx dv = IO (I.js_m_getFloat64BE idx dv)+unsafeReadFloat64LE idx dv = IO (I.js_m_unsafeGetFloat64LE idx dv)+unsafeReadFloat64BE idx dv = IO (I.js_m_unsafeGetFloat64BE idx dv)+{-# INLINE readFloat64LE #-}+{-# INLINE readFloat64BE #-}+{-# INLINE unsafeReadFloat64LE #-}+{-# INLINE unsafeReadFloat64BE #-}++-- ----------------------------------------------------------------------------+-- mutable setters++writeInt8, unsafeWriteInt8 :: Int -> Int8 -> MutableDataView -> IO ()+writeInt8 idx x dv = IO (I.js_setInt8 idx x dv)+unsafeWriteInt8 idx x dv = IO (I.js_unsafeSetInt8 idx x dv)+{-# INLINE writeInt8 #-}++writeUint8, unsafeWriteUint8 :: Int -> Word8 -> MutableDataView -> IO ()+writeUint8 idx x dv = IO (I.js_setUint8 idx x dv)+unsafeWriteUint8 idx x dv = IO (I.js_unsafeSetUint8 idx x dv)+{-# INLINE writeUint8 #-}++writeInt16LE, writeInt16BE, unsafeWriteInt16LE, unsafeWriteInt16BE+ :: Int -> Int16 -> MutableDataView -> IO ()+writeInt16LE idx x dv = IO (I.js_setInt16LE idx x dv)+writeInt16BE idx x dv = IO (I.js_setInt16BE idx x dv)+unsafeWriteInt16LE idx x dv = IO (I.js_unsafeSetInt16LE idx x dv)+unsafeWriteInt16BE idx x dv = IO (I.js_unsafeSetInt16BE idx x dv)+{-# INLINE writeInt16LE #-}+{-# INLINE writeInt16BE #-}+{-# INLINE unsafeWriteInt16LE #-}+{-# INLINE unsafeWriteInt16BE #-}++writeUint16LE, writeUint16BE, unsafeWriteUint16LE, unsafeWriteUint16BE+ :: Int -> Word16 -> MutableDataView -> IO ()+writeUint16LE idx x dv = IO (I.js_setUint16LE idx x dv)+writeUint16BE idx x dv = IO (I.js_setUint16BE idx x dv)+unsafeWriteUint16LE idx x dv = IO (I.js_unsafeSetUint16LE idx x dv)+unsafeWriteUint16BE idx x dv = IO (I.js_unsafeSetUint16BE idx x dv)+{-# INLINE writeUint16LE #-}+{-# INLINE writeUint16BE #-}+{-# INLINE unsafeWriteUint16LE #-}+{-# INLINE unsafeWriteUint16BE #-}++writeInt32LE, writeInt32BE, unsafeWriteInt32LE, unsafeWriteInt32BE+ :: Int -> Int -> MutableDataView -> IO ()+writeInt32LE idx x dv = IO (I.js_setInt32LE idx x dv)+writeInt32BE idx x dv = IO (I.js_setInt32BE idx x dv)+unsafeWriteInt32LE idx x dv = IO (I.js_unsafeSetInt32LE idx x dv)+unsafeWriteInt32BE idx x dv = IO (I.js_unsafeSetInt32BE idx x dv)+{-# INLINE writeInt32LE #-}+{-# INLINE writeInt32BE #-}+{-# INLINE unsafeWriteInt32LE #-}+{-# INLINE unsafeWriteInt32BE #-}++writeUint32LE, writeUint32BE, unsafeWriteUint32LE, unsafeWriteUint32BE+ :: Int -> Word -> MutableDataView -> IO ()+writeUint32LE idx x dv = IO (I.js_setUint32LE idx x dv)+writeUint32BE idx x dv = IO (I.js_setUint32BE idx x dv)+unsafeWriteUint32LE idx x dv = IO (I.js_unsafeSetUint32LE idx x dv)+unsafeWriteUint32BE idx x dv = IO (I.js_unsafeSetUint32BE idx x dv)+{-# INLINE writeUint32LE #-}+{-# INLINE writeUint32BE #-}+{-# INLINE unsafeWriteUint32LE #-}+{-# INLINE unsafeWriteUint32BE #-}++writeFloat32LE, writeFloat32BE, unsafeWriteFloat32LE, unsafeWriteFloat32BE+ :: Int -> Double -> MutableDataView -> IO ()+writeFloat32LE idx x dv = IO (I.js_setFloat32LE idx x dv)+writeFloat32BE idx x dv = IO (I.js_setFloat32BE idx x dv)+unsafeWriteFloat32LE idx x dv = IO (I.js_unsafeSetFloat32LE idx x dv)+unsafeWriteFloat32BE idx x dv = IO (I.js_unsafeSetFloat32BE idx x dv)+{-# INLINE writeFloat32LE #-}+{-# INLINE writeFloat32BE #-}+{-# INLINE unsafeWriteFloat32LE #-}+{-# INLINE unsafeWriteFloat32BE #-}++writeFloat64LE, writeFloat64BE, unsafeWriteFloat64LE, unsafeWriteFloat64BE+ :: Int -> Double -> MutableDataView -> IO ()+writeFloat64LE idx x dv = IO (I.js_setFloat64LE idx x dv)+writeFloat64BE idx x dv = IO (I.js_setFloat64BE idx x dv)+unsafeWriteFloat64LE idx x dv = IO (I.js_unsafeSetFloat64LE idx x dv)+unsafeWriteFloat64BE idx x dv = IO (I.js_unsafeSetFloat64BE idx x dv)+{-# INLINE writeFloat64LE #-}+{-# INLINE writeFloat64BE #-}+{-# INLINE unsafeWriteFloat64LE #-}+{-# INLINE unsafeWriteFloat64BE #-}+
+ JavaScript/TypedArray/DataView/Internal.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}++module JavaScript.TypedArray.DataView.Internal where++import Data.Int+import Data.Typeable+import Data.Word++import GHC.Exts ( State# )++import GHCJS.Prim+import GHCJS.Internal.Types++import JavaScript.TypedArray.ArrayBuffer.Internal++newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSVal+ deriving Typeable++type DataView = SomeDataView Immutable+type MutableDataView = SomeDataView Mutable+type STDataView s = SomeDataView (STMutable s)++#define JSU foreign import javascript unsafe+#define JSS foreign import javascript safe++JSU "new DataView($1)"+ js_dataView1 :: JSVal -> JSVal+JSS "new DataView($2,$1)"+ js_dataView2 :: Int -> JSVal -> SomeDataView m+JSU "new DataView($2,$1)"+ js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m+JSS "new DataView($3,$1,$2)"+ js_dataView :: Int -> Int -> JSVal -> SomeDataView m+JSU "new DataView($3,$1,$2)" + js_unsafeDataView :: Int -> Int -> JSVal -> JSVal+JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))"+ js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1)++-- ----------------------------------------------------------------------------+-- immutable getters++JSU "$2.getInt8($1)" js_i_unsafeGetInt8 :: Int -> DataView -> Int8+JSU "$2.getUint8($1)" js_i_unsafeGetUint8 :: Int -> DataView -> Word8+JSU "$2.getInt16($1)" js_i_unsafeGetInt16BE :: Int -> DataView -> Int16+JSU "$2.getInt32($1)" js_i_unsafeGetInt32BE :: Int -> DataView -> Int+JSU "$2.getUint16($1)" js_i_unsafeGetUint16BE :: Int -> DataView -> Word16+JSU "$2.getUint32($1)|0" js_i_unsafeGetUint32BE :: Int -> DataView -> Word+JSU "$2.getFloat32($1)" js_i_unsafeGetFloat32BE :: Int -> DataView -> Double+JSU "$2.getFloat64($1)" js_i_unsafeGetFloat64BE :: Int -> DataView -> Double+JSU "$2.getInt16($1,true)" js_i_unsafeGetInt16LE :: Int -> DataView -> Int16+JSU "$2.getInt32($1,true)" js_i_unsafeGetInt32LE :: Int -> DataView -> Int+JSU "$2.getUint16($1,true)" js_i_unsafeGetUint16LE :: Int -> DataView -> Word16+JSU "$2.getUint32($1,true)|0" js_i_unsafeGetUint32LE :: Int -> DataView -> Word+JSU "$2.getFloat32($1,true)" js_i_unsafeGetFloat32LE :: Int -> DataView -> Double+JSU "$2.getFloat64($1,true)" js_i_unsafeGetFloat64LE :: Int -> DataView -> Double++JSS "$2.getInt8($1)" js_i_getInt8 :: Int -> DataView -> Int8+JSS "$2.getUint8($1)" js_i_getUint8 :: Int -> DataView -> Word8+JSS "$2.getInt16($1)" js_i_getInt16BE :: Int -> DataView -> Int16+JSS "$2.getInt32($1)" js_i_getInt32BE :: Int -> DataView -> Int+JSS "$2.getUint16($1)" js_i_getUint16BE :: Int -> DataView -> Word16+JSS "$2.getUint32($1)|0" js_i_getUint32BE :: Int -> DataView -> Word+JSS "$2.getFloat32($1)" js_i_getFloat32BE :: Int -> DataView -> Double+JSS "$2.getFloat64($1)" js_i_getFloat64BE :: Int -> DataView -> Double+JSS "$2.getInt16($1,true)" js_i_getInt16LE :: Int -> DataView -> Int16+JSS "$2.getInt32($1,true)" js_i_getInt32LE :: Int -> DataView -> Int+JSS "$2.getUint16($1,true)" js_i_getUint16LE :: Int -> DataView -> Word16+JSS "$2.getUint32($1,true)|0" js_i_getUint32LE :: Int -> DataView -> Word+JSS "$2.getFloat32($1,true)" js_i_getFloat32LE :: Int -> DataView -> Double+JSS "$2.getFloat64($1,true)" js_i_getFloat64LE :: Int -> DataView -> Double++-- ----------------------------------------------------------------------------+-- mutable getters++JSU "$2.getInt8($1)" js_m_unsafeGetInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)+JSU "$2.getUint8($1)" js_m_unsafeGetUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)+JSU "$2.getInt16($1)" js_m_unsafeGetInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)+JSU "$2.getInt32($1)" js_m_unsafeGetInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)+JSU "$2.getUint16($1)" js_m_unsafeGetUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)+JSU "$2.getUint32($1)|0" js_m_unsafeGetUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)+JSU "$2.getFloat32($1)" js_m_unsafeGetFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)+JSU "$2.getFloat64($1)" js_m_unsafeGetFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)+JSU "$2.getInt16($1,true)" js_m_unsafeGetInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)+JSU "$2.getInt32($1,true)" js_m_unsafeGetInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)+JSU "$2.getUint16($1,true)" js_m_unsafeGetUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)+JSU "$2.getUint32($1,true)|0" js_m_unsafeGetUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)+JSU "$2.getFloat32($1,true)" js_m_unsafeGetFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)+JSU "$2.getFloat64($1,true)" js_m_unsafeGetFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)++JSS "$2.getInt8($1)" js_m_getInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #)+JSS "$2.getUint8($1)" js_m_getUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #)+JSS "$2.getInt16($1)" js_m_getInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)+JSS "$2.getInt32($1)" js_m_getInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)+JSS "$2.getUint16($1)" js_m_getUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)+JSS "$2.getUint32($1)|0" js_m_getUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)+JSS "$2.getFloat32($1)" js_m_getFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)+JSS "$2.getFloat64($1)" js_m_getFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)+JSS "$2.getInt16($1,true)" js_m_getInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #)+JSS "$2.getInt32($1,true)" js_m_getInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #)+JSS "$2.getUint16($1,true)" js_m_getUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #)+JSS "$2.getUint32($1,true)|0" js_m_getUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #)+JSS "$2.getFloat32($1,true)" js_m_getFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)+JSS "$2.getFloat64($1,true)" js_m_getFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #)++-- ----------------------------------------------------------------------------+-- mutable setters++JSU "$3.setInt8($1,$2)" js_unsafeSetInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setUint8($1,$2)" js_unsafeSetUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setInt16($1,$2)" js_unsafeSetInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setInt32($1,$2)" js_unsafeSetInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setUint16($1,$2)" js_unsafeSetUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setUint32($1,$2)" js_unsafeSetUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setFloat32($1,$2)" js_unsafeSetFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setFloat64($1,$2)" js_unsafeSetFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setInt16($1,$2,true)" js_unsafeSetInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setInt32($1,$2,true)" js_unsafeSetInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setUint16($1,$2,true)" js_unsafeSetUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setUint32($1,$2,true)" js_unsafeSetUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setFloat32($1,$2,true)" js_unsafeSetFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)+JSU "$3.setFloat64($1,$2,true)" js_unsafeSetFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)++JSS "$3.setInt8($1,$2)" js_setInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setUint8($1,$2)" js_setUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setInt16($1,$2)" js_setInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setInt32($1,$2)" js_setInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setUint16($1,$2)" js_setUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setUint32($1,$2)" js_setUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setFloat32($1,$2)" js_setFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setFloat64($1,$2)" js_setFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setInt16($1,$2,true)" js_setInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setInt32($1,$2,true)" js_setInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setUint16($1,$2,true)" js_setUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setUint32($1,$2,true)" js_setUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setFloat32($1,$2,true)" js_setFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)+JSS "$3.setFloat64($1,$2,true)" js_setFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #)+
+ JavaScript/TypedArray/DataView/ST.hs view
@@ -0,0 +1,232 @@+module JavaScript.TypedArray.DataView.ST+ ( STDataView+ , dataView+ , freeze, unsafeFreeze+ , thaw, unsafeThaw+ -- * reading+ , readInt8, unsafeReadInt8+ , readInt16LE, readInt16BE, unsafeReadInt16LE, unsafeReadInt16BE+ , readInt32LE, readInt32BE, unsafeReadInt32LE, unsafeReadInt32BE+ , readUint8, unsafeReadUint8+ , readUint16LE, readUint16BE, unsafeReadUint16LE, unsafeReadUint16BE+ , readUint32LE, readUint32BE, unsafeReadUint32LE, unsafeReadUint32BE+ , readFloat32LE, readFloat32BE, unsafeReadFloat32LE, unsafeReadFloat32BE+ , readFloat64LE, readFloat64BE, unsafeReadFloat64LE, unsafeReadFloat64BE+ -- * writing+ , writeInt8, unsafeWriteInt8+ , writeInt16LE, writeInt16BE, unsafeWriteInt16LE, unsafeWriteInt16BE+ , writeInt32LE, writeInt32BE, unsafeWriteInt32LE, unsafeWriteInt32BE+ , writeUint8, unsafeWriteUint8+ , writeUint16LE, writeUint16BE, unsafeWriteUint16LE, unsafeWriteUint16BE+ , writeUint32LE, writeUint32BE, unsafeWriteUint32LE, unsafeWriteUint32BE+ , writeFloat32LE, writeFloat32BE, unsafeWriteFloat32LE, unsafeWriteFloat32BE+ , writeFloat64LE, writeFloat64BE, unsafeWriteFloat64LE, unsafeWriteFloat64BE+ ) where++import Data.Int+import Data.Word++import GHC.ST++import GHCJS.Prim++import JavaScript.TypedArray.ArrayBuffer.ST+import JavaScript.TypedArray.ArrayBuffer.Internal as AI+import JavaScript.TypedArray.DataView.Internal ( SomeDataView(..), STDataView )+import qualified JavaScript.TypedArray.DataView.Internal as I+++{- | Create a 'DataView' for the whole 'ArrayBuffer' -}+dataView :: STArrayBuffer s -> STDataView s+dataView (SomeArrayBuffer b) = SomeDataView (I.js_dataView1 b)+{-# INLINE dataView #-}++{- | Create a 'STDataView' for part of an 'STArrayBuffer'+ Throws a `JSException' if the range specified by the+ offset and length exceeds the size of the buffer+ -}+dataView' :: Int -- ^ start in bytes+ -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing'+ -> STArrayBuffer s -- ^ buffer to view+ -> STDataView s+dataView' byteOffset mbyteLength (SomeArrayBuffer b) =+ case mbyteLength of+ Nothing -> I.js_dataView2 byteOffset b+ Just byteLength -> I.js_dataView byteOffset byteLength b+{-# INLINE dataView' #-}++{- | Create an 'STDataView' for part of an 'STArrayBuffer'.+ If the range specified by the offset and length exceeds the size+ off the buffer, the resulting exception from the underlying call+ kills the Haskell thread.+ -}+unsafeDataView' :: Int -- ^ start in bytes+ -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing'+ -> STArrayBuffer s -- ^ buffer to view+ -> STDataView s+unsafeDataView' byteOffset mbyteLength (SomeArrayBuffer b) =+ case mbyteLength of+ Nothing -> I.js_dataView2 byteOffset b+ Just byteLength -> I.js_dataView byteOffset byteLength b+{-# INLINE unsafeDataView' #-}++-- ----------------------------------------------------------------------------+-- mutable getters++readInt8, unsafeReadInt8 :: Int -> STDataView s -> ST s Int8+readInt8 idx dv = ST (I.js_m_getInt8 idx dv)+unsafeReadInt8 idx dv = ST (I.js_m_unsafeGetInt8 idx dv)+{-# INLINE readInt8 #-}++readUint8, unsafeReadUint8 :: Int -> STDataView s -> ST s Word8+readUint8 idx dv = ST (I.js_m_unsafeGetUint8 idx dv)+unsafeReadUint8 idx dv = ST (I.js_m_unsafeGetUint8 idx dv)+{-# INLINE readUint8 #-}++readInt16LE, readInt16BE, unsafeReadInt16LE, unsafeReadInt16BE+ :: Int -> STDataView s -> ST s Int16+readInt16LE idx dv = ST (I.js_m_getInt16LE idx dv)+readInt16BE idx dv = ST (I.js_m_getInt16BE idx dv)+unsafeReadInt16LE idx dv = ST (I.js_m_unsafeGetInt16LE idx dv)+unsafeReadInt16BE idx dv = ST (I.js_m_unsafeGetInt16BE idx dv)+{-# INLINE readInt16LE #-}+{-# INLINE readInt16BE #-}+{-# INLINE unsafeReadInt16LE #-}+{-# INLINE unsafeReadInt16BE #-}++readUint16LE, readUint16BE, unsafeReadUint16LE, unsafeReadUint16BE+ :: Int -> STDataView s -> ST s Word16+readUint16LE idx dv = ST (I.js_m_getUint16LE idx dv)+readUint16BE idx dv = ST (I.js_m_getUint16BE idx dv)+unsafeReadUint16LE idx dv = ST (I.js_m_unsafeGetUint16LE idx dv)+unsafeReadUint16BE idx dv = ST (I.js_m_unsafeGetUint16BE idx dv)+{-# INLINE readUint16LE #-}+{-# INLINE readUint16BE #-}+{-# INLINE unsafeReadUint16LE #-}+{-# INLINE unsafeReadUint16BE #-}++readInt32LE, readInt32BE, unsafeReadInt32LE, unsafeReadInt32BE+ :: Int -> STDataView s -> ST s Int+readInt32LE idx dv = ST (I.js_m_getInt32LE idx dv)+readInt32BE idx dv = ST (I.js_m_getInt32BE idx dv)+unsafeReadInt32LE idx dv = ST (I.js_m_unsafeGetInt32LE idx dv)+unsafeReadInt32BE idx dv = ST (I.js_m_unsafeGetInt32BE idx dv)+{-# INLINE readInt32LE #-}+{-# INLINE readInt32BE #-}+{-# INLINE unsafeReadInt32LE #-}+{-# INLINE unsafeReadInt32BE #-}++readUint32LE, readUint32BE, unsafeReadUint32LE, unsafeReadUint32BE+ :: Int -> STDataView s -> ST s Word+readUint32LE idx dv = ST (I.js_m_getUint32LE idx dv)+readUint32BE idx dv = ST (I.js_m_getUint32BE idx dv)+unsafeReadUint32LE idx dv = ST (I.js_m_unsafeGetUint32LE idx dv)+unsafeReadUint32BE idx dv = ST (I.js_m_unsafeGetUint32BE idx dv)+{-# INLINE readUint32LE #-}+{-# INLINE readUint32BE #-}+{-# INLINE unsafeReadUint32LE #-}+{-# INLINE unsafeReadUint32BE #-}++readFloat32LE, readFloat32BE, unsafeReadFloat32LE, unsafeReadFloat32BE+ :: Int -> STDataView s -> ST s Double+readFloat32LE idx dv = ST (I.js_m_getFloat32LE idx dv)+readFloat32BE idx dv = ST (I.js_m_getFloat32BE idx dv)+unsafeReadFloat32LE idx dv = ST (I.js_m_unsafeGetFloat32LE idx dv)+unsafeReadFloat32BE idx dv = ST (I.js_m_unsafeGetFloat32BE idx dv)+{-# INLINE readFloat32LE #-}+{-# INLINE readFloat32BE #-}+{-# INLINE unsafeReadFloat32LE #-}+{-# INLINE unsafeReadFloat32BE #-}++readFloat64LE, readFloat64BE, unsafeReadFloat64LE, unsafeReadFloat64BE+ :: Int -> STDataView s -> ST s Double+readFloat64LE idx dv = ST (I.js_m_getFloat64LE idx dv)+readFloat64BE idx dv = ST (I.js_m_getFloat64BE idx dv)+unsafeReadFloat64LE idx dv = ST (I.js_m_unsafeGetFloat64LE idx dv)+unsafeReadFloat64BE idx dv = ST (I.js_m_unsafeGetFloat64BE idx dv)+{-# INLINE readFloat64LE #-}+{-# INLINE readFloat64BE #-}+{-# INLINE unsafeReadFloat64LE #-}+{-# INLINE unsafeReadFloat64BE #-}++-- ----------------------------------------------------------------------------+-- mutable setters++writeInt8, unsafeWriteInt8 :: Int -> Int8 -> STDataView s -> ST s ()+writeInt8 idx x dv = ST (I.js_setInt8 idx x dv)+unsafeWriteInt8 idx x dv = ST (I.js_unsafeSetInt8 idx x dv)+{-# INLINE writeInt8 #-}+{-# INLINE unsafeWriteInt8 #-}++writeUint8, unsafeWriteUint8 :: Int -> Word8 -> STDataView s -> ST s ()+writeUint8 idx x dv = ST (I.js_setUint8 idx x dv)+unsafeWriteUint8 idx x dv = ST (I.js_unsafeSetUint8 idx x dv)+{-# INLINE writeUint8 #-}+{-# INLINE unsafeWriteUint8 #-}++writeInt16LE, writeInt16BE, unsafeWriteInt16LE, unsafeWriteInt16BE+ :: Int -> Int16 -> STDataView s -> ST s ()+writeInt16LE idx x dv = ST (I.js_setInt16LE idx x dv)+writeInt16BE idx x dv = ST (I.js_setInt16BE idx x dv)+unsafeWriteInt16LE idx x dv = ST (I.js_unsafeSetInt16LE idx x dv)+unsafeWriteInt16BE idx x dv = ST (I.js_unsafeSetInt16BE idx x dv)+{-# INLINE writeInt16LE #-}+{-# INLINE writeInt16BE #-}+{-# INLINE unsafeWriteInt16LE #-}+{-# INLINE unsafeWriteInt16BE #-}++writeUint16LE, writeUint16BE, unsafeWriteUint16LE, unsafeWriteUint16BE+ :: Int -> Word16 -> STDataView s -> ST s ()+writeUint16LE idx x dv = ST (I.js_setUint16LE idx x dv)+writeUint16BE idx x dv = ST (I.js_setUint16BE idx x dv)+unsafeWriteUint16LE idx x dv = ST (I.js_unsafeSetUint16LE idx x dv)+unsafeWriteUint16BE idx x dv = ST (I.js_unsafeSetUint16BE idx x dv)+{-# INLINE writeUint16LE #-}+{-# INLINE writeUint16BE #-}+{-# INLINE unsafeWriteUint16LE #-}+{-# INLINE unsafeWriteUint16BE #-}++writeInt32LE, writeInt32BE, unsafeWriteInt32LE, unsafeWriteInt32BE+ :: Int -> Int -> STDataView s -> ST s ()+writeInt32LE idx x dv = ST (I.js_setInt32LE idx x dv)+writeInt32BE idx x dv = ST (I.js_setInt32BE idx x dv)+unsafeWriteInt32LE idx x dv = ST (I.js_unsafeSetInt32LE idx x dv)+unsafeWriteInt32BE idx x dv = ST (I.js_unsafeSetInt32BE idx x dv)+{-# INLINE writeInt32LE #-}+{-# INLINE writeInt32BE #-}+{-# INLINE unsafeWriteInt32LE #-}+{-# INLINE unsafeWriteInt32BE #-}++writeUint32LE, writeUint32BE, unsafeWriteUint32LE, unsafeWriteUint32BE+ :: Int -> Word -> STDataView s -> ST s ()+writeUint32LE idx x dv = ST (I.js_setUint32LE idx x dv)+writeUint32BE idx x dv = ST (I.js_setUint32BE idx x dv)+unsafeWriteUint32LE idx x dv = ST (I.js_unsafeSetUint32LE idx x dv)+unsafeWriteUint32BE idx x dv = ST (I.js_unsafeSetUint32BE idx x dv)+{-# INLINE writeUint32LE #-}+{-# INLINE writeUint32BE #-}+{-# INLINE unsafeWriteUint32LE #-}+{-# INLINE unsafeWriteUint32BE #-}++writeFloat32LE, writeFloat32BE, unsafeWriteFloat32LE, unsafeWriteFloat32BE+ :: Int -> Double -> STDataView s -> ST s ()+writeFloat32LE idx x dv = ST (I.js_setFloat32LE idx x dv)+writeFloat32BE idx x dv = ST (I.js_setFloat32BE idx x dv)+unsafeWriteFloat32LE idx x dv = ST (I.js_unsafeSetFloat32LE idx x dv)+unsafeWriteFloat32BE idx x dv = ST (I.js_unsafeSetFloat32BE idx x dv)+{-# INLINE writeFloat32LE #-}+{-# INLINE writeFloat32BE #-}+{-# INLINE unsafeWriteFloat32LE #-}+{-# INLINE unsafeWriteFloat32BE #-}++writeFloat64LE, writeFloat64BE, unsafeWriteFloat64LE, unsafeWriteFloat64BE+ :: Int -> Double -> STDataView s -> ST s ()+writeFloat64LE idx x dv = ST (I.js_setFloat64LE idx x dv)+writeFloat64BE idx x dv = ST (I.js_setFloat64BE idx x dv)+unsafeWriteFloat64LE idx x dv = ST (I.js_unsafeSetFloat64LE idx x dv)+unsafeWriteFloat64BE idx x dv = ST (I.js_unsafeSetFloat64BE idx x dv)+{-# INLINE writeFloat64LE #-}+{-# INLINE writeFloat64BE #-}+{-# INLINE unsafeWriteFloat64LE #-}+{-# INLINE unsafeWriteFloat64BE #-}+
+ JavaScript/TypedArray/Internal.hs view
@@ -0,0 +1,536 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE KindSignatures #-}++module JavaScript.TypedArray.Internal where++import Data.Typeable++import GHC.Types+import GHC.Exts+import GHC.ST++import GHC.Int+import GHC.Word++import GHCJS.Internal.Types+import GHCJS.Buffer.Types+import GHCJS.Types++import JavaScript.Array.Internal (SomeJSArray(..), JSArray)+import JavaScript.TypedArray.ArrayBuffer+import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..))+import JavaScript.TypedArray.Internal.Types++elemSize :: SomeTypedArray e m -> Int+elemSize a = js_elemSize a+{-# INLINE [1] elemSize #-}+{-# RULES "elemSizeUint8Clamped" forall (x :: SomeUint8ClampedArray m). elemSize x = 1 #-}+{-# RULES "elemSizeUint8" forall (x :: SomeUint8Array m). elemSize x = 1 #-}+{-# RULES "elemSizeUint16" forall (x :: SomeUint16Array m). elemSize x = 2 #-}+{-# RULES "elemSizeUint32" forall (x :: SomeUint32Array m). elemSize x = 4 #-}+{-# RULES "elemSizeInt8" forall (x :: SomeInt8Array m). elemSize x = 1 #-}+{-# RULES "elemSizeInt16" forall (x :: SomeInt16Array m). elemSize x = 2 #-}+{-# RULES "elemSizeInt32" forall (x :: SomeInt32Array m). elemSize x = 4 #-}+{-# RULES "elemSizeFloat32" forall (x :: SomeFloat32Array m). elemSize x = 4 #-}+{-# RULES "elemSizeFloat64" forall (x :: SomeFloat64Array m). elemSize x = 8 #-}++instance TypedArray IOInt8Array where+ index i a = IO (indexI8 i a)+ unsafeIndex i a = IO (unsafeIndexI8 i a)+ setIndex i (I8# x) a = IO (setIndexI i x a)+ unsafeSetIndex i (I8# x) a = IO (unsafeSetIndexI i x a)+ indexOf s (I8# x) a = IO (indexOfI s x a)+ lastIndexOf s (I8# x) a = IO (lastIndexOfI s x a)+ create l = IO (js_createInt8Array l)+ fromArray a = int8ArrayFrom a+ fromArrayBuffer b = undefined++instance TypedArray IOInt16Array where+ index i a = IO (indexI16 i a)+ unsafeIndex i a = IO (unsafeIndexI16 i a)+ setIndex i (I16# x) a = IO (setIndexI i x a)+ unsafeSetIndex i (I16# x) a = IO (unsafeSetIndexI i x a)+ indexOf s (I16# x) a = IO (indexOfI s x a)+ lastIndexOf s (I16# x) a = IO (lastIndexOfI s x a)+ create l = IO (js_createInt16Array l)+ fromArray a = int16ArrayFrom a+ fromArrayBuffer b = undefined++instance TypedArray IOInt32Array where+ index i a = IO (indexI i a)+ unsafeIndex i a = IO (unsafeIndexI i a)+ setIndex i (I# x) a = IO (setIndexI i x a)+ unsafeSetIndex i (I# x) a = IO (unsafeSetIndexI i x a)+ indexOf s (I# x) a = IO (indexOfI s x a)+ lastIndexOf s (I# x) a = IO (lastIndexOfI s x a)+ create l = IO (js_createInt32Array l)+ fromArray a = int32ArrayFrom a+ fromArrayBuffer b = undefined++instance TypedArray IOUint8ClampedArray where+ index i a = IO (indexW8 i a)+ unsafeIndex i a = IO (unsafeIndexW8 i a)+ setIndex i (W8# x) a = IO (setIndexW i x a)+ unsafeSetIndex i (W8# x) a = IO (unsafeSetIndexW i x a)+ indexOf s (W8# x) a = IO (indexOfW s x a)+ lastIndexOf s (W8# x) a = IO (lastIndexOfW s x a)+ create l = IO (js_createUint8ClampedArray l)+ fromArray a = uint8ClampedArrayFrom a+ fromArrayBuffer b = undefined++instance TypedArray IOUint8Array where+ index i a = IO (indexW8 i a)+ unsafeIndex i a = IO (unsafeIndexW8 i a)+ setIndex i (W8# x) a = IO (setIndexW i x a)+ unsafeSetIndex i (W8# x) a = IO (unsafeSetIndexW i x a)+ indexOf s (W8# x) a = IO (indexOfW s x a)+ lastIndexOf s (W8# x) a = IO (lastIndexOfW s x a)+ create l = IO (js_createUint8Array l)+ fromArray a = uint8ArrayFrom a+ fromArrayBuffer b = undefined++instance TypedArray IOUint16Array where+ index i a = IO (indexW16 i a)+ unsafeIndex i a = IO (unsafeIndexW16 i a)+ setIndex i (W16# x) a = IO (setIndexW i x a)+ unsafeSetIndex i (W16# x) a = IO (unsafeSetIndexW i x a)+ indexOf s (W16# x) a = IO (indexOfW s x a)+ lastIndexOf s (W16# x) a = IO (lastIndexOfW s x a)+ create l = IO (js_createUint16Array l)+ fromArray a = uint16ArrayFrom a+ fromArrayBuffer b = undefined++instance TypedArray IOUint32Array where+ index i a = IO (indexW i a)+ unsafeIndex i a = IO (unsafeIndexW i a)+ setIndex i (W# x) a = IO (setIndexW i x a)+ unsafeSetIndex i (W# x) a = IO (unsafeSetIndexW i x a)+ indexOf s (W# x) a = IO (indexOfW s x a)+ lastIndexOf s (W# x) a = IO (lastIndexOfW s x a)+ create l = IO (js_createUint32Array l)+ fromArray a = uint32ArrayFrom a+ fromArrayBuffer b = undefined++instance TypedArray IOFloat32Array where+ index i a = IO (indexD i a)+ unsafeIndex i a = IO (unsafeIndexD i a)+ setIndex i x a = IO (setIndexD i x a)+ unsafeSetIndex i x a = IO (unsafeSetIndexD i x a)+ indexOf s x a = IO (indexOfD s x a)+ lastIndexOf s x a = IO (lastIndexOfD s x a)+ create l = IO (js_createFloat32Array l)+ fromArray a = float32ArrayFrom a+ fromArrayBuffer b = undefined++instance TypedArray IOFloat64Array where+ index i a = IO (indexD i a)+ unsafeIndex i a = IO (unsafeIndexD i a)+ setIndex i x a = IO (setIndexD i x a)+ unsafeSetIndex i x a = IO (unsafeSetIndexD i x a)+ indexOf s x a = IO (indexOfD s x a)+ lastIndexOf s x a = IO (lastIndexOfD s x a)+ create l = IO (js_createFloat64Array l)+ fromArray a = float64ArrayFrom a+ fromArrayBuffer b = undefined+++class TypedArray a where+ unsafeIndex :: Int -> a -> IO (Elem a)+ index :: Int -> a -> IO (Elem a)+ unsafeSetIndex :: Int -> Elem a -> a -> IO ()+ setIndex :: Int -> Elem a -> a -> IO ()+ create :: Int -> IO a+ fromArray :: SomeJSArray m -> IO a+ fromArrayBuffer :: MutableArrayBuffer -> Int -> Maybe Int -> IO a+ indexOf :: Int -> Elem a -> a -> IO Int+ lastIndexOf :: Int -> Elem a -> a -> IO Int++-- -----------------------------------------------------------------------------++indexI :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+indexI a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I# v #)+{-# INLINE indexI #-}++indexI16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int16 #)+indexI16 a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I16# v #)+{-# INLINE indexI16 #-}++indexI8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int8 #)+indexI8 a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I8# v #)+{-# INLINE indexI8 #-}++indexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word #)+indexW a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W# v #)+{-# INLINE indexW #-}++indexW16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word16 #)+indexW16 a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W16# v #)+{-# INLINE indexW16 #-}++indexW8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word8 #)+indexW8 a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W8# v #)+{-# INLINE indexW8 #-}++indexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #)+indexD a i = \s -> js_indexD a i s+{-# INLINE indexD #-}++-- -----------------------------------------------------------------------------++unsafeIndexI :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+unsafeIndexI a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I# v #)+{-# INLINE unsafeIndexI #-}++unsafeIndexI16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int16 #)+unsafeIndexI16 a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I16# v #)+{-# INLINE unsafeIndexI16 #-}++unsafeIndexI8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int8 #)+unsafeIndexI8 a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I8# v #)+{-# INLINE unsafeIndexI8 #-}++unsafeIndexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word #)+unsafeIndexW a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W# v #)+{-# INLINE unsafeIndexW #-}++unsafeIndexW16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word16 #)+unsafeIndexW16 a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W16# v #)+{-# INLINE unsafeIndexW16 #-}++unsafeIndexW8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word8 #)+unsafeIndexW8 a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W8# v #)+{-# INLINE unsafeIndexW8 #-}++unsafeIndexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #)+unsafeIndexD a i = \s -> js_unsafeIndexD a i s+{-# INLINE unsafeIndexD #-}++-- -----------------------------------------------------------------------------++int8ArrayFrom :: SomeJSArray m0 -> IO (SomeInt8Array m1)+int8ArrayFrom a = js_int8ArrayFromArray a+{-# INLINE int8ArrayFrom #-}++int16ArrayFrom :: SomeJSArray m0 -> IO (SomeInt16Array m1)+int16ArrayFrom a = js_int16ArrayFromArray a+{-# INLINE int16ArrayFrom #-}++int32ArrayFrom :: SomeJSArray m0 -> IO (SomeInt32Array m1)+int32ArrayFrom a = js_int32ArrayFromArray a+{-# INLINE int32ArrayFrom #-}++uint8ArrayFrom :: SomeJSArray m0 -> IO (SomeUint8Array m1)+uint8ArrayFrom a = js_uint8ArrayFromArray a+{-# INLINE uint8ArrayFrom #-}++uint8ClampedArrayFrom :: SomeJSArray m0 -> IO (SomeUint8ClampedArray m1)+uint8ClampedArrayFrom a = js_uint8ClampedArrayFromArray a+{-# INLINE uint8ClampedArrayFrom #-}++uint16ArrayFrom :: SomeJSArray m0 -> IO (SomeUint16Array m1)+uint16ArrayFrom a = js_uint16ArrayFromArray a+{-# INLINE uint16ArrayFrom #-}++uint32ArrayFrom :: SomeJSArray m0 -> IO (SomeUint32Array m1)+uint32ArrayFrom a = js_uint32ArrayFromArray a+{-# INLINE uint32ArrayFrom #-}++float32ArrayFrom :: SomeJSArray m0 -> IO (SomeFloat32Array m1)+float32ArrayFrom a = js_float32ArrayFromArray a+{-# INLINE float32ArrayFrom #-}++float64ArrayFrom :: SomeJSArray m0 -> IO (SomeFloat64Array m1)+float64ArrayFrom a = js_float64ArrayFromArray a+{-# INLINE float64ArrayFrom #-}++-- -----------------------------------------------------------------------------++setIndexI :: Mutability m ~ IsMutable+ => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #)+setIndexI i x a = js_setIndexI i x a+{-# INLINE setIndexI #-}++unsafeSetIndexI :: Mutability m ~ IsMutable+ => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #)+unsafeSetIndexI i x a = js_unsafeSetIndexI i x a+{-# INLINE unsafeSetIndexI #-}++setIndexW :: Mutability m ~ IsMutable+ => Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #)+setIndexW i x a = js_setIndexW i x a+{-# INLINE setIndexW #-}++unsafeSetIndexW :: Mutability m ~ IsMutable+ => Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #)+unsafeSetIndexW i x a = js_unsafeSetIndexW i x a+{-# INLINE unsafeSetIndexW #-}++setIndexD :: Mutability m ~ IsMutable+ => Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #)+setIndexD i x a = js_setIndexD i x a+{-# INLINE setIndexD #-}++unsafeSetIndexD :: Mutability m ~ IsMutable+ => Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #)+unsafeSetIndexD i x a = js_unsafeSetIndexD i x a+{-# INLINE unsafeSetIndexD #-}++indexOfI :: Mutability m ~ IsMutable+ => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+indexOfI s x a = js_indexOfI s x a+{-# INLINE indexOfI #-}++indexOfW :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+indexOfW s x a = js_indexOfW s x a+{-# INLINE indexOfW #-}++indexOfD :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+indexOfD s x a = js_indexOfD s x a+{-# INLINE indexOfD #-}++lastIndexOfI :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+lastIndexOfI s x a = js_lastIndexOfI s x a+{-# INLINE lastIndexOfI #-}++lastIndexOfW :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+lastIndexOfW s x a = js_lastIndexOfW s x a+{-# INLINE lastIndexOfW #-}++lastIndexOfD :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+lastIndexOfD s x a = js_lastIndexOfD s x a+{-# INLINE lastIndexOfD #-}++-- -----------------------------------------------------------------------------+-- non-class operations usable for all typed array+{-| length of the typed array in elements -}+length :: SomeTypedArray e m -> Int+length x = js_length x+{-# INLINE length #-}++{-| length of the array in bytes -}+byteLength :: SomeTypedArray e m -> Int+byteLength x = js_byteLength x+{-# INLINE byteLength #-}++{-| offset of the array in the buffer -}+byteOffset :: SomeTypedArray e m -> Int+byteOffset x = js_byteOffset x+{-# INLINE byteOffset #-}++{-| the underlying buffer of the array #-}+buffer :: SomeTypedArray e m -> SomeArrayBuffer m+buffer x = js_buffer x+{-# INLINE buffer #-}++{-| create a view of the existing array -}+subarray :: Int -> Int -> SomeTypedArray e m -> SomeTypedArray e m+subarray begin end x = js_subarray begin end x+{-# INLINE subarray #-}++-- fixme convert JSException to Haskell exception+{-| copy the elements of one typed array to another -}+set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> IO ()+set offset src dest = IO (js_set offset src dest)+{-# INLINE set #-}++unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> IO ()+unsafeSet offset src dest = IO (js_unsafeSet offset src dest)+{-# INLINE unsafeSet #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$1.length" js_length :: SomeTypedArray e m -> Int+foreign import javascript unsafe+ "$1.byteLength" js_byteLength :: SomeTypedArray e m -> Int+foreign import javascript unsafe+ "$1.byteOffset" js_byteOffset :: SomeTypedArray e m -> Int+foreign import javascript unsafe+ "$1.buffer" js_buffer :: SomeTypedArray e m -> SomeArrayBuffer m+foreign import javascript unsafe+ "$3.subarray($1,$2)"+ js_subarray :: Int -> Int -> SomeTypedArray e m -> SomeTypedArray e m+foreign import javascript safe+ "$3.set($1,$2)"+ js_set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 m1 -> State# s -> (# State# s, () #)+foreign import javascript unsafe+ "$3.set($1,$2)"+ js_unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 m1 -> State# s -> (# State# s, () #)+foreign import javascript unsafe+ "$1.BYTES_PER_ELEMENT"+ js_elemSize :: SomeTypedArray e m -> Int++-- -----------------------------------------------------------------------------+-- index++foreign import javascript safe+ "$2[$1]" js_indexI+ :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int# #)+foreign import javascript safe+ "$2[$1]" js_indexW+ :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word# #)+foreign import javascript safe+ "$2[$1]" js_indexD+ :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #)++foreign import javascript unsafe+ "$2[$1]" js_unsafeIndexI+ :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int# #)+foreign import javascript unsafe+ "$2[$1]" js_unsafeIndexW+ :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word# #)+foreign import javascript unsafe+ "$2[$1]" js_unsafeIndexD+ :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #)++-- -----------------------------------------------------------------------------+-- setIndex++foreign import javascript safe+ "$3[$1] = $2;" js_setIndexI+ :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #)+foreign import javascript safe+ "$3[$1] = $2;" js_setIndexW+ :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #)+foreign import javascript safe+ "$3[$1] = $2;" js_setIndexD+ :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #)++foreign import javascript unsafe+ "$3[$1] = $2;" js_unsafeSetIndexI+ :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #)+foreign import javascript unsafe+ "$3[$1] = $2;" js_unsafeSetIndexW+ :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #)+foreign import javascript unsafe+ "$3[$1] = $2;" js_unsafeSetIndexD+ :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #)++-- ------------------------------------------------------------------------------++foreign import javascript unsafe+ "$3.indexOf($2,$1)" js_indexOfI+ :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+foreign import javascript unsafe+ "$3.indexOf($2,$1)" js_indexOfW+ :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+foreign import javascript unsafe+ "$3.indexOf($2,$1)" js_indexOfD+ :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #)++foreign import javascript unsafe+ "$3.lastIndexOf($2,$1)" js_lastIndexOfI+ :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+foreign import javascript unsafe+ "$3.lastIndexOf($2,$1)" js_lastIndexOfW+ :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #)+foreign import javascript unsafe+ "$3.lastIndexOf($2,$1)" js_lastIndexOfD+ :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #)++-- ------------------------------------------------------------------------------+-- create++foreign import javascript unsafe+ "new Int8Array($1)"+ js_createInt8Array :: Int -> State# s -> (# State# s, SomeInt8Array m #)+foreign import javascript unsafe+ "new Int16Array($1)"+ js_createInt16Array :: Int -> State# s -> (# State# s, SomeInt16Array m #)+foreign import javascript unsafe+ "new Int32Array($1)"+ js_createInt32Array :: Int -> State# s -> (# State# s, SomeInt32Array m #)++foreign import javascript unsafe+ "new Uint8ClampedArray($1)"+ js_createUint8ClampedArray :: Int -> State# s -> (# State# s, SomeUint8ClampedArray m #)+foreign import javascript unsafe+ "new Uint8Array($1)"+ js_createUint8Array :: Int -> State# s -> (# State# s, SomeUint8Array m #)+foreign import javascript unsafe+ "new Uint16Array($1)"+ js_createUint16Array :: Int -> State# s -> (# State# s, SomeUint16Array m #)+foreign import javascript unsafe+ "new Uint32Array($1)"+ js_createUint32Array :: Int -> State# s -> (# State# s, SomeUint32Array m #)++foreign import javascript unsafe+ "new Float32Array($1)"+ js_createFloat32Array :: Int -> State# s -> (# State# s, SomeFloat32Array m #)+foreign import javascript unsafe+ "new Float64Array($1)"+ js_createFloat64Array :: Int -> State# s -> (# State# s, SomeFloat64Array m #)++-- ------------------------------------------------------------------------------+-- from array++foreign import javascript unsafe+ "Int8Array.from($1)"+ js_int8ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt8Array m1)+foreign import javascript unsafe+ "Int16Array.from($1)"+ js_int16ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt16Array m1)+foreign import javascript unsafe+ "Int32Array.from($1)"+ js_int32ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt32Array m1)+foreign import javascript unsafe+ "Uint8ClampedArray.from($1)"+ js_uint8ClampedArrayFromArray :: SomeJSArray m0 -> IO (SomeUint8ClampedArray m1)+foreign import javascript unsafe+ "Uint8Array.from($1)"+ js_uint8ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint8Array m1)+foreign import javascript unsafe+ "Uint16Array.from($1)"+ js_uint16ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint16Array m1)+foreign import javascript unsafe+ "Uint32Array.from($1)"+ js_uint32ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint32Array m1)+foreign import javascript unsafe+ "Float32Array.from($1)"+ js_float32ArrayFromArray :: SomeJSArray m0 -> IO (SomeFloat32Array m1)+foreign import javascript unsafe+ "Float64Array.from($1)"+ js_float64ArrayFromArray :: SomeJSArray m0 -> IO (SomeFloat64Array m1)++-- ------------------------------------------------------------------------------+-- from ArrayBuffer++foreign import javascript unsafe+ "new Int8Array($1)"+ js_int8ArrayFromJSVal :: JSVal -> SomeInt8Array m+foreign import javascript unsafe+ "new Int16Array($1)"+ js_int16ArrayFromJSVal :: JSVal -> SomeInt16Array m+foreign import javascript unsafe+ "new Int32Array($1)"+ js_int32ArrayFromJSVal :: JSVal -> SomeInt32Array m+foreign import javascript unsafe+ "new Uint8ClampedArray($1)"+ js_uint8ClampedArrayFromJSVal :: JSVal -> SomeUint8ClampedArray m+foreign import javascript unsafe+ "new Uint8Array($1)"+ js_uint8ArrayFromJSVal :: JSVal -> SomeUint8Array m+foreign import javascript unsafe+ "new Uint16Array($1)"+ js_uint16ArrayFromJSVal :: JSVal -> SomeUint16Array m+foreign import javascript unsafe+ "new Uint32Array($1)"+ js_uint32ArrayFromJSVal :: JSVal -> SomeUint32Array m+foreign import javascript unsafe+ "new Float32Array($1)"+ js_float32ArrayFromJSVal :: JSVal -> SomeFloat32Array m+foreign import javascript unsafe+ "new Float64Array($1)"+ js_float64ArrayFromJSVal :: JSVal -> SomeFloat64Array m+
+ JavaScript/TypedArray/Internal/Types.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}++module JavaScript.TypedArray.Internal.Types where++import GHCJS.Types+import GHCJS.Internal.Types++import Data.Int+import Data.Typeable+import Data.Word++newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) =+ SomeTypedArray JSVal deriving Typeable+instance IsJSVal (SomeTypedArray e m)++{-+newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal+ deriving (Typeable)+-}++type SomeSTTypedArray s (e :: TypedArrayElem) = SomeTypedArray e (STMutable s)++-- -----------------------------------------------------------------------------++data TypedArrayElem = Int8Elem+ | Int16Elem+ | Int32Elem+ | Uint8Elem+ | Uint16Elem+ | Uint32Elem+ | Uint8ClampedElem+ | Float32Elem+ | Float64Elem++-- -----------------------------------------------------------------------------++type SomeInt8Array = SomeTypedArray Int8Elem+type SomeInt16Array = SomeTypedArray Int16Elem+type SomeInt32Array = SomeTypedArray Int32Elem++type SomeUint8Array = SomeTypedArray Uint8Elem+type SomeUint16Array = SomeTypedArray Uint16Elem+type SomeUint32Array = SomeTypedArray Uint32Elem++type SomeFloat32Array = SomeTypedArray Float32Elem+type SomeFloat64Array = SomeTypedArray Float64Elem++type SomeUint8ClampedArray = SomeTypedArray Uint8ClampedElem++-- -----------------------------------------------------------------------------++type Int8Array = SomeInt8Array Immutable+type Int16Array = SomeInt16Array Immutable+type Int32Array = SomeInt32Array Immutable++type Uint8Array = SomeUint8Array Immutable+type Uint16Array = SomeUint16Array Immutable+type Uint32Array = SomeUint32Array Immutable++type Uint8ClampedArray = SomeUint8ClampedArray Immutable++type Float32Array = SomeFloat32Array Immutable+type Float64Array = SomeFloat64Array Immutable++-- -----------------------------------------------------------------------------++type IOInt8Array = SomeInt8Array Mutable+type IOInt16Array = SomeInt16Array Mutable+type IOInt32Array = SomeInt32Array Mutable++type IOUint8Array = SomeUint8Array Mutable+type IOUint16Array = SomeUint16Array Mutable+type IOUint32Array = SomeUint32Array Mutable++type IOUint8ClampedArray = SomeUint8ClampedArray Mutable++type IOFloat32Array = SomeFloat32Array Mutable+type IOFloat64Array = SomeFloat64Array Mutable++-- -----------------------------------------------------------------------------++type STInt8Array s = SomeSTTypedArray s Int8Elem+type STInt16Array s = SomeSTTypedArray s Int16Elem+type STInt32Array s = SomeSTTypedArray s Int32Elem++type STUint8Array s = SomeSTTypedArray s Uint8Elem+type STUint16Array s = SomeSTTypedArray s Uint16Elem+type STUint32Array s = SomeSTTypedArray s Uint32Elem++type STFloat32Array s = SomeSTTypedArray s Float32Elem+type STFloat64Array s = SomeSTTypedArray s Float64Elem++type STUint8ClampedArray s = SomeSTTypedArray s Uint8ClampedElem++-- -----------------------------------------------------------------------------++type family Elem x where+ Elem (SomeUint8Array m) = Word8+ Elem (SomeUint8ClampedArray m) = Word8+ Elem (SomeUint16Array m) = Word16+ Elem (SomeUint32Array m) = Word+ Elem (SomeInt8Array m) = Int8+ Elem (SomeInt16Array m) = Int16+ Elem (SomeInt32Array m) = Int+ Elem (SomeFloat32Array m) = Double+ Elem (SomeFloat64Array m) = Double+ + Elem (STUint8Array s) = Word8+ Elem (STUint8ClampedArray s) = Word8+ Elem (STUint16Array s) = Word16+ Elem (STUint32Array s) = Word+ Elem (STInt8Array s) = Int8+ Elem (STInt16Array s) = Int16+ Elem (STInt32Array s) = Int+ Elem (STFloat32Array s) = Double+ Elem (STFloat64Array s) = Double+
+ JavaScript/TypedArray/ST.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE MagicHash, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}++module JavaScript.TypedArray.ST+ ( {- STTypedArray(..)+ , -} STInt8Array, STInt16Array, STInt32Array+ , STUint8Array, STUint16Array, STUint32Array+ , STFloat32Array, STFloat64Array+ , STUint8ClampedArray+ , length+ , byteLength+ , byteOffset+ , buffer+ , subarray+ ) where+++import Prelude ( Maybe, undefined )++import GHC.Exts+import GHC.ST+import GHC.Int+import GHC.Word++import GHCJS.Types++import GHCJS.Buffer.Types+import GHCJS.Prim+import GHCJS.Internal.Types++import qualified Data.ByteString as B+import Data.Primitive.ByteArray++import qualified JavaScript.Array.Internal as JSA++import qualified JavaScript.TypedArray.Internal as I+import JavaScript.TypedArray.Internal ( length, byteLength, byteOffset, buffer, subarray ) +import JavaScript.TypedArray.Internal.Types+import JavaScript.TypedArray.ArrayBuffer.Internal+ ( SomeArrayBuffer, MutableArrayBuffer, STArrayBuffer )+import JavaScript.TypedArray.DataView.Internal ( SomeDataView )++class STTypedArray s a where+ unsafeIndex :: Int -> a -> ST s (Elem a)+ index :: Int -> a -> ST s (Elem a)+ unsafeSetIndex :: Int -> Elem a -> a -> ST s ()+ setIndex :: Int -> Elem a -> a -> ST s ()+ create :: Int -> ST s a+-- fromArray :: JSArray e -> ST s a+ fromBuffer :: STArrayBuffer s -> Int -> Maybe Int -> ST s a+ indexOf :: Int -> Elem a -> a -> ST s Int+ lastIndexOf :: Int -> Elem a -> a -> ST s Int++instance STTypedArray s (STInt8Array s) where+ index i a = ST (I.indexI8 i a)+ unsafeIndex i a = ST (I.unsafeIndexI8 i a)+ setIndex i (I8# x) a = ST (I.setIndexI i x a)+ unsafeSetIndex i (I8# x) a = ST (I.unsafeSetIndexI i x a)+ indexOf s (I8# x) a = ST (I.indexOfI s x a)+ fromBuffer = undefined+ lastIndexOf s (I8# x) a = ST (I.lastIndexOfI s x a)+ create l = ST (I.js_createInt8Array l)++-- ---------------------------------------------------------------------------+{-+setIndexI :: SomeTypedArray e m -> Int -> Int# -> ST s ()+setIndexI a i x = ST (I.js_setIndexI a i x)+{-# INLINE setIndexI #-}++unsafeSetIndexI :: SomeTypedArray e m -> Int -> Int# -> ST s ()+unsafeSetIndexI a i x = ST (I.js_unsafeSetIndexI a i x)+{-# INLINE unsafeSetIndexI #-}++setIndexW :: SomeTypedArray e m -> Int -> Word# -> ST s ()+setIndexW a i x = ST (I.js_setIndexW a i x)+{-# INLINE setIndexW #-}++unsafeSetIndexW :: SomeTypedArray e m -> Int -> Word# -> ST s ()+unsafeSetIndexW a i x = ST (I.js_unsafeSetIndexW a i x)+{-# INLINE unsafeSetIndexW #-}++indexOfI :: SomeTypedArray e m -> Int# -> ST s Int+indexOfI a x = ST (I.js_indexOfI a x)+{-# INLINE indexOfI #-}++indexOfW :: SomeTypedArray e m -> Word# -> ST s Int+indexOfW a x = ST (I.js_indexOfW a x)+{-# INLINE indexOfW #-}+-}+-- ---------------------------------------------------------------------------+{-+length :: SomeSTTypedArray s e -> Int+length x = I.length x -- ST (I.js_length x)+{-# INLINE length #-}++byteLength :: SomeSTTypedArray s e -> Int+byteLength x = ST (I.js_byteLength x)+{-# INLINE byteLength #-}++byteOffset :: SomeSTTypedArray s e -> Int+byteOffset x = ST (I.js_byteOffset x)+{-# INLINE byteOffset #-}++buffer :: SomeSTTypedArray s e -> STArrayBuffer s+buffer x = ST (I.js_buffer x)+{-# INLINE buffer #-}++subarray :: Int -> Int -> SomeSTTypedArray s e -> SomeSTTypedArray s e+subarray begin end x = ST (I.js_subarray begin end x)+{-# INLINE subarray #-}++-- fixme convert JSException to Haskell exception+set :: SomeSTTypedArray s e -> Int -> SomeSTTypedArray s e -> ST s ()+set src offset dest = ST (I.js_set src offset dest)+{-# INLINE set #-}++unsafeSet :: SomeSTTypedArray s e -> Int -> SomeSTTypedArray s e -> ST s ()+unsafeSet src offset dest = ST (I.js_unsafeSet src offset dest)+{-# INLINE unsafeSet #-}++-}
+ JavaScript/Web/AnimationFrame.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE InterruptibleFFI #-}+{-# LANGUAGE DeriveDataTypeable #-}++{- |+ Animation frames are the browser's mechanism for smooth animation.+ An animation frame callback is run just before the browser repaints.++ When the content window is inactive, for example when the user is looking+ at another tab, it can take a long time for an animation frame callback+ to happen. Be careful structuring evaluation around this! Typically this+ means carefully forcing the data before the animation frame is requested,+ so the callback can run quickly and predictably.+ -}++module JavaScript.Web.AnimationFrame+ ( waitForAnimationFrame+ , inAnimationFrame+ , cancelAnimationFrame+ , AnimationFrameHandle+ ) where++import GHCJS.Foreign.Callback+import GHCJS.Marshal.Pure+import GHCJS.Types++import Control.Exception (onException)+import Data.Typeable++newtype AnimationFrameHandle = AnimationFrameHandle JSVal+ deriving (Typeable)++{- |+ Wait for an animation frame callback to continue running the current+ thread. Use 'GHCJS.Concurrent.synchronously' if the thread should+ not be preempted. This will return the high-performance clock time+ stamp once an animation frame is reached.+ -}+waitForAnimationFrame :: IO Double+waitForAnimationFrame = do+ h <- js_makeAnimationFrameHandle+ js_waitForAnimationFrame h `onException` js_cancelAnimationFrame h++{- |+ Run the action in an animationframe callback. The action runs in a+ synchronous thread, and is passed the high-performance clock time+ stamp for that frame.+ -}+inAnimationFrame :: OnBlocked -- ^ what to do when encountering a blocking call+ -> (Double -> IO ()) -- ^ the action to run+ -> IO AnimationFrameHandle+inAnimationFrame onBlocked x = do+ cb <- syncCallback1 onBlocked (x . pFromJSVal)+ h <- js_makeAnimationFrameHandleCallback (jsval cb)+ js_requestAnimationFrame h+ return h++cancelAnimationFrame :: AnimationFrameHandle -> IO ()+cancelAnimationFrame h = js_cancelAnimationFrame h+{-# INLINE cancelAnimationFrame #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe "{ handle: null, callback: null }"+ js_makeAnimationFrameHandle :: IO AnimationFrameHandle+foreign import javascript unsafe "{ handle: null, callback: $1 }"+ js_makeAnimationFrameHandleCallback :: JSVal -> IO AnimationFrameHandle+foreign import javascript unsafe "h$animationFrameCancel"+ js_cancelAnimationFrame :: AnimationFrameHandle -> IO ()+foreign import javascript interruptible+ "$1.handle = window.requestAnimationFrame($c);"+ js_waitForAnimationFrame :: AnimationFrameHandle -> IO Double+foreign import javascript unsafe "h$animationFrameRequest"+ js_requestAnimationFrame :: AnimationFrameHandle -> IO ()
+ JavaScript/Web/Blob.hs view
@@ -0,0 +1,10 @@+module JavaScript.Web.Blob ( Blob+ , size+ , contentType+ , slice+ , isClosed+ , close+ ) where++import JavaScript.Web.Blob.Internal+
+ JavaScript/Web/Blob/Internal.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}++module JavaScript.Web.Blob.Internal where++import Data.Typeable++import GHCJS.Types++data BlobType = BlobTypeBlob+ | BlobTypeFile++newtype SomeBlob (a :: BlobType) = SomeBlob JSVal deriving Typeable++type File = SomeBlob BlobTypeFile+type Blob = SomeBlob BlobTypeBlob+ +size :: SomeBlob a -> Int+size b = js_size b+{-# INLINE size #-}++contentType :: SomeBlob a -> JSString+contentType b = js_type b+{-# INLINE contentType #-}++-- is the type correct, does slicing a File give another File?+slice :: Int -> Int -> JSString -> SomeBlob a -> SomeBlob a+slice start end contentType b = js_slice start end contentType b+{-# INLINE slice #-}++isClosed :: SomeBlob a -> IO Bool+isClosed b = js_isClosed b+{-# INLINE isClosed #-}++close :: SomeBlob a -> IO ()+close b = js_close b+{-# INLINE close #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe "$1.size" js_size :: SomeBlob a -> Int+foreign import javascript unsafe "$1.type" js_type :: SomeBlob a -> JSString++-- fixme figure out if we need to support older browsers with obsolete slice+foreign import javascript unsafe "$4.slice($1,$2,$3)"+ js_slice :: Int -> Int -> JSString -> SomeBlob a -> SomeBlob a++foreign import javascript unsafe "$1.isClosed"+ js_isClosed :: SomeBlob a -> IO Bool+foreign import javascript unsafe "$1.close();"+ js_close :: SomeBlob a -> IO ()
+ JavaScript/Web/Canvas.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, JavaScriptFFI,+ OverloadedStrings, DeriveDataTypeable+ #-}++module JavaScript.Web.Canvas ( Context+ , Canvas+ , Image+ , TextAlign(..)+ , TextBaseline(..)+ , LineCap(..)+ , LineJoin(..)+ , Repeat(..)+ , Gradient+ , Pattern+ , create+ , unsafeToCanvas+ , toCanvas+ , getContext+ , save+ , restore+ , scale+ , rotate+ , translate+ , transform+ , setTransform+ , fill+ , fillRule+ , stroke+ , beginPath+ , closePath+ , clip+ , moveTo+ , lineTo+ , quadraticCurveTo+ , bezierCurveTo+ , arc+ , arcTo+ , rect+ , isPointInPath+ , fillStyle+ , strokeStyle+ , globalAlpha+ , lineJoin+ , lineCap+ , lineWidth+ , setLineDash+ , lineDashOffset+ , miterLimit+ , fillText+ , strokeText+ , font+ , measureText+ , textAlign+ , textBaseline+ , fillRect+ , strokeRect+ , clearRect+ , drawImage+ , width+ , setWidth+ , height+ , setHeight+ ) where++import Prelude hiding (Left, Right)++import Control.Applicative+import Control.Monad++import Data.Data+import Data.Maybe (fromJust)+import Data.Text (Text)+import Data.Typeable++import GHCJS.Foreign+import GHCJS.Marshal+import GHCJS.Types++import JavaScript.Web.Canvas.Internal++import JavaScript.Object (Object)+import qualified JavaScript.Object as O+import JavaScript.Array (JSArray)+import qualified JavaScript.Array as A++data TextAlign = Start+ | End+ | Left+ | Right+ | Center+ deriving (Eq, Show, Enum, Data, Typeable)++data TextBaseline = Top + | Hanging + | Middle+ | Alphabetic+ | Ideographic+ | Bottom+ deriving (Eq, Show, Enum, Data, Typeable)++data LineJoin = LineJoinBevel+ | LineJoinRound+ | LineJoinMiter+ deriving (Eq, Show, Enum)++data LineCap = LineCapButt+ | LineCapRound+ | LineCapSquare deriving (Eq, Show, Enum, Data, Typeable)++data Repeat = Repeat+ | RepeatX+ | RepeatY+ | NoRepeat+ deriving (Eq, Ord, Show, Enum, Data, Typeable)++unsafeToCanvas :: JSVal -> Canvas+unsafeToCanvas r = Canvas r+{-# INLINE unsafeToCanvas #-}++toCanvas :: JSVal -> Maybe Canvas+toCanvas x = error "toCanvas" -- fixme+{-# INLINE toCanvas #-}++create :: Int -> Int -> IO Canvas+create = js_create+{-# INLINE create #-}++getContext :: Canvas -> IO Context+getContext c = js_getContext c+{-# INLINE getContext #-}++save :: Context -> IO ()+save ctx = js_save ctx+{-# INLINE save #-}++restore :: Context -> IO ()+restore = js_restore+{-# INLINE restore #-}++transform :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO ()+transform = js_transform+{-# INLINE transform #-}++setTransform :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO ()+setTransform = js_setTransform+{-# INLINE setTransform #-}++scale :: Double -> Double -> Context -> IO ()+scale x y ctx = js_scale x y ctx+{-# INLINE scale #-}++translate :: Double -> Double -> Context -> IO ()+translate x y ctx = js_translate x y ctx+{-# INLINE translate #-}++rotate :: Double -> Context -> IO ()+rotate r ctx = js_rotate r ctx+{-# INLINE rotate #-}++fill :: Context -> IO ()+fill ctx = js_fill ctx+{-# INLINE fill #-}++fillRule :: JSString -> Context -> IO ()+fillRule rule ctx = js_fill_rule rule ctx+{-# INLINE fillRule #-}++stroke :: Context -> IO ()+stroke = js_stroke+{-# INLINE stroke #-}++beginPath :: Context -> IO ()+beginPath = js_beginPath+{-# INLINE beginPath #-}++closePath :: Context -> IO ()+closePath = js_closePath+{-# INLINE closePath #-}++clip :: Context -> IO ()+clip = js_clip+{-# INLINE clip #-}++moveTo :: Double -> Double -> Context -> IO ()+moveTo = js_moveTo+{-# INLINE moveTo #-}++lineTo :: Double -> Double -> Context -> IO ()+lineTo = js_lineTo+{-# INLINE lineTo #-}++quadraticCurveTo :: Double -> Double -> Double -> Double -> Context -> IO ()+quadraticCurveTo = js_quadraticCurveTo+{-# INLINE quadraticCurveTo #-}++bezierCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO ()+bezierCurveTo = js_bezierCurveTo+{-# INLINE bezierCurveTo #-}++arc :: Double -> Double -> Double -> Double -> Double -> Bool -> Context -> IO ()+arc a b c d e bl ctx = js_arc a b c d e bl ctx+{-# INLINE arc #-}++arcTo :: Double -> Double -> Double -> Double -> Double -> Context -> IO ()+arcTo = js_arcTo+{-# INLINE arcTo #-}++rect :: Double -> Double -> Double -> Double -> Context -> IO ()+rect = js_rect+{-# INLINE rect #-}++isPointInPath :: Double -> Double -> Context -> IO ()+isPointInPath = js_isPointInPath+{-# INLINE isPointInPath #-}++fillStyle :: Int -> Int -> Int -> Double -> Context -> IO ()+fillStyle = js_fillStyle+{-# INLINE fillStyle #-}++strokeStyle :: Int -> Int -> Int -> Double -> Context -> IO ()+strokeStyle = js_strokeStyle+{-# INLINE strokeStyle #-}++globalAlpha :: Double -> Context -> IO ()+globalAlpha = js_globalAlpha+{-# INLINE globalAlpha #-}++lineJoin :: LineJoin -> Context -> IO ()+lineJoin LineJoinBevel ctx = js_lineJoin "bevel" ctx+lineJoin LineJoinRound ctx = js_lineJoin "round" ctx+lineJoin LineJoinMiter ctx = js_lineJoin "miter" ctx+{-# INLINE lineJoin #-}++lineCap :: LineCap -> Context -> IO ()+lineCap LineCapButt ctx = js_lineCap "butt" ctx+lineCap LineCapRound ctx = js_lineCap "round" ctx+lineCap LineCapSquare ctx = js_lineCap "square" ctx+{-# INLINE lineCap #-}++miterLimit :: Double -> Context -> IO ()+miterLimit = js_miterLimit+{-# INLINE miterLimit #-}++-- | pass an array of numbers+setLineDash :: JSArray -> Context -> IO ()+setLineDash arr ctx = js_setLineDash arr ctx+{-# INLINE setLineDash #-}++lineDashOffset :: Double -> Context -> IO ()+lineDashOffset = js_lineDashOffset+{-# INLINE lineDashOffset #-}++textAlign :: TextAlign -> Context -> IO ()+textAlign align ctx = case align of+ Start -> js_textAlign "start" ctx+ End -> js_textAlign "end" ctx+ Left -> js_textAlign "left" ctx+ Right -> js_textAlign "right" ctx+ Center -> js_textAlign "center" ctx+{-# INLINE textAlign #-}++textBaseline :: TextBaseline -> Context -> IO ()+textBaseline baseline ctx = case baseline of + Top -> js_textBaseline "top" ctx+ Hanging -> js_textBaseline "hanging" ctx+ Middle -> js_textBaseline "middle" ctx+ Alphabetic -> js_textBaseline "alphabetic" ctx+ Ideographic -> js_textBaseline "ideographic" ctx+ Bottom -> js_textBaseline "bottom" ctx+{-# INLINE textBaseline #-}++lineWidth :: Double -> Context -> IO ()+lineWidth = js_lineWidth+{-# INLINE lineWidth #-}++fillText :: JSString -> Double -> Double -> Context -> IO ()+fillText t x y ctx = js_fillText t x y ctx+{-# INLINE fillText #-}++strokeText :: JSString -> Double -> Double -> Context -> IO ()+strokeText t x y ctx = js_strokeText t x y ctx+{-# INLINE strokeText #-}++font :: JSString -> Context -> IO ()+font f ctx = js_font f ctx+{-# INLINE font #-}++measureText :: JSString -> Context -> IO Double+measureText t ctx = js_measureText t ctx+ >>= O.getProp "width"+ >>= liftM fromJust . fromJSVal+{-# INLINE measureText #-}++fillRect :: Double -> Double -> Double -> Double -> Context -> IO ()+fillRect = js_fillRect+{-# INLINE fillRect #-}++clearRect :: Double -> Double -> Double -> Double -> Context -> IO ()+clearRect = js_clearRect+{-# INLINE clearRect #-}++strokeRect :: Double -> Double -> Double -> Double -> Context -> IO ()+strokeRect = js_strokeRect+{-# INLINE strokeRect #-}++drawImage :: Image -> Int -> Int -> Int -> Int -> Context -> IO ()+drawImage = js_drawImage+{-# INLINE drawImage #-}++createPattern :: Image -> Repeat -> Context -> IO Pattern+createPattern img Repeat ctx = js_createPattern img "repeat" ctx+createPattern img RepeatX ctx = js_createPattern img "repeat-x" ctx+createPattern img RepeatY ctx = js_createPattern img "repeat-y" ctx+createPattern img NoRepeat ctx = js_createPattern img "no-repeat" ctx+{-# INLINE createPattern #-}++setWidth :: Int -> Canvas -> IO ()+setWidth w c = js_setWidth w c+{-# INLINE setWidth #-}++width :: Canvas -> IO Int+width c = js_width c+{-# INLINE width #-}++setHeight :: Int -> Canvas -> IO ()+setHeight h c = js_setHeight h c+{-# INLINE setHeight #-}++height :: Canvas -> IO Int+height c = js_height c+{-# INLINE height #-}++-- ----------------------------------------------------------------------------++foreign import javascript unsafe "$r = document.createElement('canvas');\+ \$r.width = $1;\+ \$r.height = $2;"+ js_create :: Int -> Int -> IO Canvas+foreign import javascript unsafe "$1.getContext('2d')"+ js_getContext :: Canvas -> IO Context+foreign import javascript unsafe "$1.save()"+ js_save :: Context -> IO ()+foreign import javascript unsafe "$1.restore()"+ js_restore :: Context -> IO ()+foreign import javascript unsafe "$7.transform($1,$2,$3,$4,$5,$6)"+ js_transform :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$7.setTransform($1,$2,$3,$4,$5,$6)"+ js_setTransform :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$3.scale($1,$2)"+ js_scale :: Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$3.translate($1,$2)"+ js_translate :: Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$2.rotate($1)"+ js_rotate :: Double -> Context -> IO ()+foreign import javascript unsafe "$1.fill()"+ js_fill :: Context -> IO ()+foreign import javascript unsafe "$2.fill($1)"+ js_fill_rule :: JSString -> Context -> IO ()+foreign import javascript unsafe "$1.stroke()"+ js_stroke :: Context -> IO ()+foreign import javascript unsafe "$1.beginPath()"+ js_beginPath :: Context -> IO ()+foreign import javascript unsafe "$1.closePath()"+ js_closePath :: Context -> IO ()+foreign import javascript unsafe "$1.clip()"+ js_clip :: Context -> IO ()+foreign import javascript unsafe "$3.moveTo($1,$2)"+ js_moveTo :: Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$3.lineTo($1,$2)"+ js_lineTo :: Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$5.quadraticCurveTo($1,$2,$3,$4)"+ js_quadraticCurveTo :: Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$7.bezierCurveTo($1,$2,$3,$4,$5,$6)"+ js_bezierCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$7.arc($1,$2,$3,$4,$5,$6)"+ js_arc :: Double -> Double -> Double -> Double -> Double -> Bool -> Context -> IO ()+foreign import javascript unsafe "$6.arcTo($1,$2,$3,$4,$5)"+ js_arcTo :: Double -> Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$5.rect($1,$2,$3,$4)"+ js_rect :: Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$3.isPointInPath($1,$2)"+ js_isPointInPath :: Double -> Double -> Context -> IO ()+foreign import javascript unsafe+ "$5.fillStyle = 'rgba(' + $1 + ',' + $2 + ',' + $3 + ',' + $4 + ')'"+ js_fillStyle :: Int -> Int -> Int -> Double -> Context -> IO ()+foreign import javascript unsafe+ "$5.strokeStyle = 'rgba(' + $1 + ',' + $2 + ',' + $3 + ',' + $4 + ')'"+ js_strokeStyle :: Int -> Int -> Int -> Double -> Context -> IO ()+foreign import javascript unsafe "$2.globalAlpha = $1"+ js_globalAlpha :: Double -> Context -> IO ()+foreign import javascript unsafe+ "$2.lineJoin = $1"+ js_lineJoin :: JSString -> Context -> IO ()+foreign import javascript unsafe "$2.lineCap = $1"+ js_lineCap :: JSString -> Context -> IO ()+foreign import javascript unsafe "$2.miterLimit = $1"+ js_miterLimit :: Double -> Context -> IO ()+foreign import javascript unsafe "$2.setLineDash($1)"+ js_setLineDash :: JSArray -> Context -> IO ()+foreign import javascript unsafe "$2.lineDashOffset = $1"+ js_lineDashOffset :: Double -> Context -> IO ()+foreign import javascript unsafe "$2.font = $1"+ js_font :: JSString -> Context -> IO ()+foreign import javascript unsafe "$2.textAlign = $1"+ js_textAlign :: JSString -> Context -> IO ()+foreign import javascript unsafe "$2.textBaseline = $1"+ js_textBaseline :: JSString -> Context -> IO ()+foreign import javascript unsafe "$2.lineWidth = $1"+ js_lineWidth :: Double -> Context -> IO ()+foreign import javascript unsafe "$4.fillText($1,$2,$3)"+ js_fillText :: JSString -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$4.strokeText($1,$2,$3)"+ js_strokeText :: JSString -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$2.measureText($1)"+ js_measureText :: JSString -> Context -> IO Object+foreign import javascript unsafe "$5.fillRect($1,$2,$3,$4)"+ js_fillRect :: Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$5.clearRect($1,$2,$3,$4)"+ js_clearRect :: Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$5.strokeRect($1,$2,$3,$4)"+ js_strokeRect :: Double -> Double -> Double -> Double -> Context -> IO ()+foreign import javascript unsafe "$6.drawImage($1,$2,$3,$4,$5)"+ js_drawImage :: Image -> Int -> Int -> Int -> Int -> Context -> IO () +foreign import javascript unsafe "$3.createPattern($1,$2)"+ js_createPattern :: Image -> JSString -> Context -> IO Pattern+foreign import javascript unsafe "$1.width"+ js_width :: Canvas -> IO Int+foreign import javascript unsafe "$1.height"+ js_height :: Canvas -> IO Int+foreign import javascript unsafe "$2.width = $1;"+ js_setWidth :: Int -> Canvas -> IO ()+foreign import javascript unsafe "$2.height = $1;"+ js_setHeight :: Int -> Canvas -> IO ()
+ JavaScript/Web/Canvas/ImageData.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++module JavaScript.Web.Canvas.ImageData ( ImageData+ , width+ , height+ , getData+ ) where++import JavaScript.TypedArray++import JavaScript.Web.Canvas.Internal++height :: ImageData -> Int+height i = js_height i+{-# INLINE height #-}++width :: ImageData -> Int+width i = js_width i+{-# INLINE width #-}++getData :: ImageData -> Uint8ClampedArray+getData i = js_getData i+{-# INLINE getData #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$1.width" js_width :: ImageData -> Int+foreign import javascript unsafe+ "$1.height" js_height :: ImageData -> Int+foreign import javascript unsafe+ "$1.data" js_getData :: ImageData -> Uint8ClampedArray+
+ JavaScript/Web/Canvas/Internal.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE EmptyDataDecls #-}++module JavaScript.Web.Canvas.Internal ( Canvas(..)+ , Context(..)+ , Gradient(..)+ , Image(..)+ , ImageData(..)+ , Pattern(..)+ , TextMetrics(..)+ ) where++import GHCJS.Types++newtype Canvas = Canvas JSVal+newtype Context = Context JSVal+newtype Gradient = Gradient JSVal+newtype Image = Image JSVal+newtype ImageData = ImageData JSVal+newtype Pattern = Pattern JSVal+newtype TextMetrics = TextMetrics JSVal++instance IsJSVal Canvas+instance IsJSVal Context+instance IsJSVal Gradient+instance IsJSVal Image+instance IsJSVal ImageData+instance IsJSVal Pattern+instance IsJSVal TextMetrics
+ JavaScript/Web/Canvas/TextMetrics.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++module JavaScript.Web.Canvas.TextMetrics ( width+ , actualBoundingBoxLeft+ , actualBoundingBoxRight+ , fontBoundingBoxAscent+ , fontBoundingBoxDescent+ , actualBoundingBoxAscent+ , actualBoundingBoxDescent+ , emHeightAscent+ , emHeightDescent+ , hangingBaseline+ , alphabeticBaseline+ , ideographicBaseline+ ) where++import JavaScript.Web.Canvas.Internal++width :: TextMetrics -> Double+width tm = js_width tm+{-# INLINE width #-}++actualBoundingBoxLeft :: TextMetrics -> Double+actualBoundingBoxLeft tm = js_actualBoundingBoxLeft tm+{-# INLINE actualBoundingBoxLeft #-}++actualBoundingBoxRight :: TextMetrics -> Double+actualBoundingBoxRight tm = js_actualBoundingBoxRight tm+{-# INLINE actualBoundingBoxRight #-}++fontBoundingBoxAscent :: TextMetrics -> Double+fontBoundingBoxAscent tm = js_fontBoundingBoxAscent tm+{-# INLINE fontBoundingBoxAscent #-}++fontBoundingBoxDescent :: TextMetrics -> Double+fontBoundingBoxDescent tm = js_fontBoundingBoxDescent tm+{-# INLINE fontBoundingBoxDescent #-}++actualBoundingBoxAscent :: TextMetrics -> Double+actualBoundingBoxAscent tm = js_actualBoundingBoxAscent tm+{-# INLINE actualBoundingBoxAscent #-}++actualBoundingBoxDescent :: TextMetrics -> Double+actualBoundingBoxDescent tm = js_actualBoundingBoxDescent tm+{-# INLINE actualBoundingBoxDescent #-}++emHeightAscent :: TextMetrics -> Double+emHeightAscent tm = js_emHeightAscent tm+{-# INLINE emHeightAscent #-}++emHeightDescent :: TextMetrics -> Double+emHeightDescent tm = js_emHeightDescent tm+{-# INLINE emHeightDescent #-}++hangingBaseline :: TextMetrics -> Double+hangingBaseline tm = js_hangingBaseline tm+{-# INLINE hangingBaseline #-}++alphabeticBaseline :: TextMetrics -> Double+alphabeticBaseline tm = js_alphabeticBaseline tm+{-# INLINE alphabeticBaseline #-}++ideographicBaseline :: TextMetrics -> Double+ideographicBaseline tm = js_ideographicBaseline tm+{-# INLINE ideographicBaseline #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$1.width" js_width :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.actualBoundingBoxLeft" js_actualBoundingBoxLeft :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.actualBoundingBoxRight" js_actualBoundingBoxRight :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.fontBoundingBoxAscent" js_fontBoundingBoxAscent :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.fontBoundingBoxDescent" js_fontBoundingBoxDescent :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.actualBoundingBoxAscent" js_actualBoundingBoxAscent :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.actualBoundingBoxDescent" js_actualBoundingBoxDescent :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.emHeightAscent" js_emHeightAscent :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.emHeightDescent" js_emHeightDescent :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.hangingBaseline" js_hangingBaseline :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.alphabeticBaseline" js_alphabeticBaseline :: TextMetrics -> Double+foreign import javascript unsafe+ "$1.ideographicBaseline" js_ideographicBaseline :: TextMetrics -> Double++
+ JavaScript/Web/CloseEvent.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++module JavaScript.Web.CloseEvent ( CloseEvent+ , getCode+ , getReason+ , wasClean+ ) where++import Data.JSString++import JavaScript.Web.CloseEvent.Internal++getCode :: CloseEvent -> Int+getCode c = js_getCode c+{-# INLINE getCode #-}++getReason :: CloseEvent -> JSString+getReason c = js_getReason c+{-# INLINE getReason #-}++wasClean :: CloseEvent -> Bool+wasClean c = js_wasClean c+{-# INLINE wasClean #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$1.code" js_getCode :: CloseEvent -> Int+foreign import javascript unsafe+ "$1.reason" js_getReason :: CloseEvent -> JSString+foreign import javascript unsafe+ "$1.wasClean" js_wasClean :: CloseEvent -> Bool
+ JavaScript/Web/CloseEvent/Internal.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveDataTypeable #-}++module JavaScript.Web.CloseEvent.Internal where++import GHCJS.Types++import Data.Typeable++newtype CloseEvent = CloseEvent JSVal deriving Typeable+
+ JavaScript/Web/ErrorEvent.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}++module JavaScript.Web.ErrorEvent ( ErrorEvent+ , message+ , filename+ , lineno+ , colno+ , error+ ) where++import Prelude hiding (error)++import GHCJS.Types++import Data.JSString++import JavaScript.Web.ErrorEvent.Internal++message :: ErrorEvent -> JSString+message ee = js_getMessage ee+{-# INLINE message #-}++filename :: ErrorEvent -> JSString+filename ee = js_getFilename ee+{-# INLINE filename #-}++lineno :: ErrorEvent -> Int+lineno ee = js_getLineno ee+{-# INLINE lineno #-}++colno :: ErrorEvent -> Int+colno ee = js_getColno ee+{-# INLINE colno #-}++error :: ErrorEvent -> JSVal+error ee = js_getError ee+{-# INLINE error #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe "$1.message"+ js_getMessage :: ErrorEvent -> JSString+foreign import javascript unsafe "$1.filename"+ js_getFilename :: ErrorEvent -> JSString+foreign import javascript unsafe "$1.lineno"+ js_getLineno :: ErrorEvent -> Int+foreign import javascript unsafe "$1.colno"+ js_getColno :: ErrorEvent -> Int+foreign import javascript unsafe "$1.error"+ js_getError :: ErrorEvent -> JSVal
+ JavaScript/Web/ErrorEvent/Internal.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DeriveDataTypeable #-}++module JavaScript.Web.ErrorEvent.Internal where++import GHCJS.Types++import Data.Typeable++newtype ErrorEvent = ErrorEvent JSVal deriving Typeable
+ JavaScript/Web/File.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++module JavaScript.Web.File ( File+ -- Blob operations+ , size+ , contentType+ , slice+ , isClosed+ , close+ -- additional File operations+ , name+ , lastModified+ ) where++import JavaScript.Web.Blob.Internal++import Data.JSString++name :: File -> JSString+name b = js_name b+{-# INLINE name #-}++lastModified :: File -> Double+lastModified b = js_lastModified b+{-# INLINE lastModified #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe "$1.name" js_name :: File -> JSString+foreign import javascript unsafe "$1.lastModified" js_lastModified :: File -> Double+
+ JavaScript/Web/History.hs view
@@ -0,0 +1,3 @@+module JavaScript.Web.History () where++-- todo: implement
+ JavaScript/Web/Location.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE DeriveDataTypeable #-}++module JavaScript.Web.Location ( Location+ , getWindowLocation+ , getHref+ , setHref+ , getProtocol+ , setProtocol+ , getHost+ , setHost+ , getHostname+ , setHostname+ , getPort+ , setPort+ , getPathname+ , setPathname+ , getSearch+ , setSearch+ , getHash+ , setHash+ , getUsername+ , setUsername+ , getPassword+ , setPassword+ , getOrigin+ , assign+ , reload+ , replace+ ) where++import Data.Typeable++import Data.JSString (JSString)+import qualified Data.JSString as JSS++import GHCJS.Types++newtype Location = Location JSVal deriving (Typeable)+instance IsJSVal Location++getWindowLocation :: IO Location+getWindowLocation = js_getWindowLocation+{-# INLINE getWindowLocation #-}++getHref :: Location -> IO JSString+getHref = js_getHref+{-# INLINE getHref #-}++setHref :: JSString -> Location -> IO ()+setHref = js_setHref+{-# INLINE setHref #-}++getProtocol :: Location -> IO JSString+getProtocol = js_getProtocol+{-# INLINE getProtocol #-}++setProtocol :: JSString -> Location -> IO ()+setProtocol = js_setProtocol+{-# INLINE setProtocol #-}++getHost :: Location -> IO JSString+getHost = js_getHost+{-# INLINE getHost #-}++setHost :: JSString -> Location -> IO ()+setHost = js_setHost+{-# INLINE setHost #-}++getHostname :: Location -> IO JSString+getHostname = js_getHostname+{-# INLINE getHostname #-}++setHostname :: JSString -> Location -> IO ()+setHostname = js_setHostname+{-# INLINE setHostname #-}++getPort :: Location -> IO JSString+getPort = js_getPort+{-# INLINE getPort #-}++setPort :: JSString -> Location -> IO ()+setPort = js_setPort+{-# INLINE setPort #-}++getPathname :: Location -> IO JSString+getPathname = js_getPathname+{-# INLINE getPathname #-}++setPathname :: JSString -> Location -> IO ()+setPathname = js_setPathname+{-# INLINE setPathname #-}++getSearch :: Location -> IO JSString+getSearch = js_getSearch+{-# INLINE getSearch #-}++setSearch :: JSString -> Location -> IO ()+setSearch = js_setSearch+{-# INLINE setSearch #-}++getHash :: Location -> IO JSString+getHash = js_getHash+{-# INLINE getHash #-}++setHash :: JSString -> Location -> IO ()+setHash = js_setHash+{-# INLINE setHash #-}++getUsername :: Location -> IO JSString+getUsername = js_getUsername+{-# INLINE getUsername #-}++setUsername :: JSString -> Location -> IO ()+setUsername = js_setUsername+{-# INLINE setUsername #-}++getPassword :: Location -> IO JSString+getPassword = js_getPassword+{-# INLINE getPassword #-}++setPassword :: JSString -> Location -> IO ()+setPassword = js_setPassword+{-# INLINE setPassword #-}++getOrigin :: Location -> IO JSString+getOrigin = js_getUsername+{-# INLINE getOrigin #-}++assign :: JSString -> Location -> IO ()+assign = js_assign+{-# INLINE assign #-}++reload :: Bool -> Location -> IO ()+reload = js_reload+{-# INLINE reload #-}++replace :: JSString -> Location -> IO ()+replace = js_assign+{-# INLINE replace #-}++-------------------------------------------------------------------------------++foreign import javascript safe "window.location" js_getWindowLocation :: IO Location++foreign import javascript unsafe "$1.href" js_getHref :: Location -> IO JSString+foreign import javascript unsafe "$1.protocol" js_getProtocol :: Location -> IO JSString+foreign import javascript unsafe "$1.host" js_getHost :: Location -> IO JSString+foreign import javascript unsafe "$1.hostname" js_getHostname :: Location -> IO JSString+foreign import javascript unsafe "$1.port" js_getPort :: Location -> IO JSString+foreign import javascript unsafe "$1.pathname" js_getPathname :: Location -> IO JSString+foreign import javascript unsafe "$1.search" js_getSearch :: Location -> IO JSString+foreign import javascript unsafe "$1.hash" js_getHash :: Location -> IO JSString+foreign import javascript unsafe "$1.username" js_getUsername :: Location -> IO JSString+foreign import javascript unsafe "$1.password" js_getPassword :: Location -> IO JSString+foreign import javascript unsafe "$1.origin" js_getOrigin :: Location -> IO JSString++foreign import javascript safe "$2.href = $1;" js_setHref :: JSString -> Location -> IO ()+foreign import javascript safe "$2.protocol = $1;" js_setProtocol :: JSString -> Location -> IO ()+foreign import javascript safe "$2.host = $1;" js_setHost :: JSString -> Location -> IO ()+foreign import javascript safe "$2.hostname = $1;" js_setHostname :: JSString -> Location -> IO ()+foreign import javascript safe "$2.port = $1;" js_setPort :: JSString -> Location -> IO ()+foreign import javascript safe "$2.pathname = $1;" js_setPathname :: JSString -> Location -> IO ()+foreign import javascript safe "$2.search = $1;" js_setSearch :: JSString -> Location -> IO ()+foreign import javascript safe "$2.hash = $1;" js_setHash :: JSString -> Location -> IO ()+foreign import javascript safe "$2.username = $1;" js_setUsername :: JSString -> Location -> IO ()+foreign import javascript safe "$2.password = $1;" js_setPassword :: JSString -> Location -> IO ()++foreign import javascript safe "$2.assign($1);" js_assign :: JSString -> Location -> IO ()+foreign import javascript safe "$2.reload($1);" js_reload :: Bool -> Location -> IO ()+foreign import javascript safe "$2.replace($1);" js_replace :: JSString -> Location -> IO ()
+ JavaScript/Web/MessageEvent.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, DeriveDataTypeable,+ UnboxedTuples, GHCForeignImportPrim, UnliftedFFITypes,+ MagicHash+ #-}++module JavaScript.Web.MessageEvent ( MessageEvent+ , getData+ , MessageEventData(..)+ ) where++import GHCJS.Types++import GHC.Exts++import Data.Typeable++import JavaScript.Web.MessageEvent.Internal++import JavaScript.Web.Blob.Internal (Blob, SomeBlob(..))+import JavaScript.TypedArray.ArrayBuffer.Internal (ArrayBuffer, SomeArrayBuffer(..))+import Data.JSString.Internal.Type (JSString(..))+++data MessageEventData = StringData JSString+ | BlobData Blob+ | ArrayBufferData ArrayBuffer+ deriving (Typeable)++getData :: MessageEvent -> MessageEventData+getData me = case js_getData me of+ (# 1#, r #) -> StringData (JSString r)+ (# 2#, r #) -> BlobData (SomeBlob r)+ (# 3#, r #) -> ArrayBufferData (SomeArrayBuffer r)+{-# INLINE getData #-}++++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$r2 = $1.data;\+ \$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 3 : 2)"+ js_getData :: MessageEvent -> (# Int#, JSVal #)
+ JavaScript/Web/MessageEvent/Internal.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DeriveDataTypeable #-}++module JavaScript.Web.MessageEvent.Internal where++import Data.Typeable++import GHCJS.Types++newtype MessageEvent = MessageEvent JSVal deriving (Typeable)
+ JavaScript/Web/Performance.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++{- | The Performance interface represents timing-related performance information for the given page.+ -}++module JavaScript.Web.Performance+ ( now+ ) where++import GHCJS.Foreign.Callback+import GHCJS.Marshal.Pure+import GHCJS.Types++import Control.Exception (onException)+import Data.Typeable++{- | The 'now' computation returns a high resolution time stamp, measured in+ milliseconds, accurate to one thousandth of a millisecond.++ The value represented by 0 varies according the context, but+ in dedicated workers created from a Window context, the epoch is the value+ of the @PerformanceTiming.navigationStart@ property.+ -}+now :: IO Double+now = js_performanceNow+{-# INLINE now #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe "performance.now()"+ js_performanceNow :: IO Double
+ JavaScript/Web/Storage.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++module JavaScript.Web.Storage ( localStorage+ , sessionStorage+ , Storage+ , getLength+ , getIndex+ , getItem+ , setItem+ , removeItem+ , clear+ ) where++import GHCJS.Types++import Data.JSString+import Data.JSString.Internal.Type++import JavaScript.Web.Storage.Internal++localStorage :: Storage+localStorage = js_localStorage+{-# INLINE localStorage #-}++sessionStorage :: Storage+sessionStorage = js_sessionStorage+{-# INLINE sessionStorage #-}++getLength :: Storage -> IO Int+getLength s = js_getLength s+{-# INLINE getLength #-}++getIndex :: Int -> Storage -> IO (Maybe JSString)+getIndex i s = do+ r <- js_getIndex i s+ return $ if isNull r then Nothing else Just (JSString r)+{-# INLINE getIndex #-}++getItem :: JSString -> Storage -> IO (Maybe JSString)+getItem key s = do+ r <- js_getItem key s+ return $ if isNull r then Nothing else Just (JSString r)+{-# INLINE getItem #-}++setItem :: JSString -> JSString -> Storage -> IO ()+setItem key val s = js_setItem key val s+{-# INLINE setItem #-}++removeItem :: JSString -> Storage -> IO ()+removeItem key s = js_removeItem key s+{-# INLINE removeItem #-}++clear :: Storage -> IO ()+clear s = js_clear s+{-# INLINE clear #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "window.localStorage" js_localStorage :: Storage+foreign import javascript unsafe+ "window.sessionStorage" js_sessionStorage :: Storage+foreign import javascript unsafe+ "$1.length" js_getLength :: Storage -> IO Int+foreign import javascript unsafe+ "$2.key($1)" js_getIndex :: Int -> Storage -> IO JSVal+foreign import javascript unsafe+ "$2.getItem($1)" js_getItem :: JSString -> Storage -> IO JSVal+foreign import javascript safe+ "$3.setItem($1,$2)" js_setItem :: JSString -> JSString -> Storage -> IO ()+foreign import javascript unsafe+ "$2.removeItem($1)" js_removeItem :: JSString -> Storage -> IO ()+foreign import javascript unsafe+ "$1.clear();" js_clear :: Storage -> IO ()
+ JavaScript/Web/Storage/Internal.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveDataTypeable #-}++module JavaScript.Web.Storage.Internal where++import GHCJS.Types++import Data.Typeable++newtype Storage = Storage JSVal deriving Typeable+newtype StorageEvent = StorageEvent JSVal deriving Typeable
+ JavaScript/Web/StorageEvent.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++module JavaScript.Web.StorageEvent ( StorageEvent+ , key+ , oldValue+ , newValue+ , url+ , storageArea+ ) where++import Data.JSString+--import Data.JSString.Internal -- fixme+import Data.JSString.Internal.Type -- fixme++import GHCJS.Types++import JavaScript.Web.Storage.Internal++key :: StorageEvent -> Maybe JSString+key se | isNull r = Nothing+ | otherwise = Just (JSString r)+ where+ r = js_getKey se+{-# INLINE key #-}++oldValue :: StorageEvent -> Maybe JSString+oldValue se | isNull r = Nothing+ | otherwise = Just (JSString r)+ where+ r = js_getOldValue se+{-# INLINE oldValue #-}++newValue :: StorageEvent -> Maybe JSString+newValue se | isNull r = Nothing+ | otherwise = Just (JSString r)+ where+ r = js_getNewValue se+{-# INLINE newValue #-}++url :: StorageEvent -> JSString+url se = js_getUrl se+{-# INLINE url #-}++storageArea :: StorageEvent -> Maybe Storage+storageArea se | isNull r = Nothing+ | otherwise = Just (Storage r)+ where+ r = js_getStorageArea se+{-# INLINE storageArea #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$1.key" js_getKey :: StorageEvent -> JSVal+foreign import javascript unsafe+ "$1.oldValue" js_getOldValue :: StorageEvent -> JSVal+foreign import javascript unsafe+ "$1.newValue" js_getNewValue :: StorageEvent -> JSVal+foreign import javascript unsafe+ "$1.url" js_getUrl :: StorageEvent -> JSString+foreign import javascript unsafe+ "$1.storageArea" js_getStorageArea :: StorageEvent -> JSVal
+ JavaScript/Web/WebSocket.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE InterruptibleFFI #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE UnboxedTuples #-}++module JavaScript.Web.WebSocket ( WebSocket+ , WebSocketRequest(..)+ , ReadyState(..)+ , BinaryType(..)+ , connect+ , close+ , send+ , sendArrayBuffer+ , sendBlob+ , getBufferedAmount+ , getExtensions+ , getProtocol+ , getReadyState+ , getBinaryType+ , setBinaryType+ , getUrl+ ) where++import GHCJS.Concurrent+import GHCJS.Prim+import GHCJS.Foreign.Callback.Internal (Callback(..))+import qualified GHCJS.Foreign.Callback as CB++import GHC.Exts++import Control.Exception+import Control.Monad++import Data.Data+import Data.Maybe+import Data.Typeable++import System.IO++import Data.JSString (JSString)+import qualified Data.JSString as JSS++import JavaScript.Array (JSArray)+import qualified JavaScript.Array as JSA+import JavaScript.TypedArray.ArrayBuffer (ArrayBuffer)+import JavaScript.Web.Blob (Blob)+import JavaScript.Web.MessageEvent+import JavaScript.Web.MessageEvent.Internal+import JavaScript.Web.CloseEvent+import JavaScript.Web.CloseEvent.Internal+import JavaScript.Web.ErrorEvent+import JavaScript.Web.ErrorEvent.Internal++import Unsafe.Coerce++data WebSocketRequest = WebSocketRequest+ { url :: JSString+ , protocols :: [JSString]+ , onClose :: Maybe (CloseEvent -> IO ()) -- ^ called when the connection closes (at most once)+ , onMessage :: Maybe (MessageEvent -> IO ()) -- ^ called for each message+ }++newtype WebSocket = WebSocket JSVal+-- instance IsJSVal WebSocket++data ReadyState = Connecting | Open | Closing | Closed+ deriving (Data, Typeable, Enum, Eq, Ord, Show)++data BinaryType = Blob | ArrayBuffer+ deriving (Data, Typeable, Enum, Eq, Ord, Show)++{- | create a WebSocket -} +connect :: WebSocketRequest -> IO WebSocket+connect req = do+ mcb <- maybeCallback MessageEvent (onMessage req)+ ccb <- maybeCallback CloseEvent (onClose req)+ withoutPreemption $ do+ ws <- case protocols req of+ [] -> js_createDefault (url req)+ [x] -> js_createStr (url req) x+ (js_open ws mcb ccb >>= handleOpenErr >> return ws) `onException` js_close 1000 "Haskell Exception" ws++maybeCallback :: (JSVal -> a) -> Maybe (a -> IO ()) -> IO JSVal+maybeCallback _ Nothing = return jsNull+maybeCallback f (Just g) = do+ Callback cb <- CB.syncCallback1 CB.ContinueAsync (g . f)+ return cb++handleOpenErr :: JSVal -> IO ()+handleOpenErr r+ | isNull r = return ()+ | otherwise = throwIO (userError "WebSocket failed to connect") -- fixme++{- | close a websocket and release the callbacks -}+close :: Maybe Int -> Maybe JSString -> WebSocket -> IO ()+close value reason ws =+ js_close (fromMaybe 1000 value) (fromMaybe JSS.empty reason) ws+{-# INLINE close #-}++send :: JSString -> WebSocket -> IO ()+send xs ws = js_send xs ws+{-# INLINE send #-}++sendBlob :: Blob -> WebSocket -> IO ()+sendBlob = js_sendBlob+{-# INLINE sendBlob #-}++sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO ()+sendArrayBuffer = js_sendArrayBuffer+{-# INLINE sendArrayBuffer #-}++getBufferedAmount :: WebSocket -> IO Int+getBufferedAmount ws = js_getBufferedAmount ws+{-# INLINE getBufferedAmount #-}++getExtensions :: WebSocket -> IO JSString+getExtensions ws = js_getExtensions ws+{-# INLINE getExtensions #-}++getProtocol :: WebSocket -> IO JSString+getProtocol ws = js_getProtocol ws+{-# INLINE getProtocol #-}++getReadyState :: WebSocket -> IO ReadyState+getReadyState ws = fmap toEnum (js_getReadyState ws)+{-# INLINE getReadyState #-}++getBinaryType :: WebSocket -> IO BinaryType+getBinaryType ws = fmap toEnum (js_getBinaryType ws)+{-# INLINE getBinaryType #-}++getUrl :: WebSocket -> JSString+getUrl ws = js_getUrl ws+{-# INLINE getUrl #-}++getLastError :: WebSocket -> IO (Maybe ErrorEvent)+getLastError ws = do+ le <- js_getLastError ws+ return $ if isNull le then Nothing else Just (ErrorEvent le)+{-# INLINE getLastError #-}++setBinaryType :: BinaryType -> WebSocket -> IO ()+setBinaryType Blob = js_setBinaryType (JSS.pack "blob")+setBinaryType ArrayBuffer = js_setBinaryType (JSS.pack "arraybuffer")++-- -----------------------------------------------------------------------------++foreign import javascript safe+ "new WebSocket($1)" js_createDefault :: JSString -> IO WebSocket+foreign import javascript safe+ "new WebSocket($1, $2)" js_createStr :: JSString -> JSString -> IO WebSocket+foreign import javascript safe+ "new WebSocket($1, $2)" js_createArr :: JSString -> JSArray -> IO WebSocket++foreign import javascript interruptible+ "h$openWebSocket($1, $2, $3, $c);"+ js_open :: WebSocket -> JSVal -> JSVal -> IO JSVal+foreign import javascript safe+ "h$closeWebSocket($1, $2, $3);"+ js_close :: Int -> JSString -> WebSocket -> IO ()+foreign import javascript unsafe+ "$2.send($1);" js_send :: JSString -> WebSocket -> IO ()+foreign import javascript unsafe+ "$2.send($1);" js_sendBlob :: Blob -> WebSocket -> IO ()+foreign import javascript unsafe+ "$2.send($1);" js_sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO ()+foreign import javascript unsafe+ "$1.bufferedAmount" js_getBufferedAmount :: WebSocket -> IO Int+foreign import javascript unsafe+ "$1.readyState" js_getReadyState :: WebSocket -> IO Int+foreign import javascript unsafe+ "$1.protocol" js_getProtocol :: WebSocket -> IO JSString+foreign import javascript unsafe+ "$1.extensions" js_getExtensions :: WebSocket -> IO JSString+foreign import javascript unsafe+ "$1.url" js_getUrl :: WebSocket -> JSString+foreign import javascript unsafe+ "$1.binaryType === 'blob' ? 0 : 1"+ js_getBinaryType :: WebSocket -> IO Int+foreign import javascript unsafe+ "$1.lastError" js_getLastError :: WebSocket -> IO JSVal++foreign import javascript unsafe+ "$2.binaryType = $1"+ js_setBinaryType :: JSString -> WebSocket -> IO ()
+ JavaScript/Web/Worker.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}++module JavaScript.Web.Worker ( Worker+ , create+ , postMessage+ , terminate+ ) where++import GHCJS.Prim++import Data.JSString+import Data.Typeable++newtype Worker = Worker JSVal deriving Typeable++create :: JSString -> IO Worker+create script = js_create script+{-# INLINE create #-}++postMessage :: JSVal -> Worker -> IO ()+postMessage msg w = js_postMessage msg w+{-# INLINE postMessage #-}++terminate :: Worker -> IO ()+terminate w = js_terminate w+{-# INLINE terminate #-}++-- -----------------------------------------------------------------------------++foreign import javascript unsafe + "new Worker($1)" js_create :: JSString -> IO Worker+foreign import javascript unsafe+ "$2.postMessage($1)" js_postMessage :: JSVal -> Worker -> IO ()+foreign import javascript unsafe+ "$1.terminate()" js_terminate :: Worker -> IO ()
+ JavaScript/Web/XMLHttpRequest.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE RankNTypes, OverloadedStrings, DeriveDataTypeable,+ ForeignFunctionInterface, JavaScriptFFI, EmptyDataDecls,+ TypeFamilies, DataKinds, ScopedTypeVariables,+ FlexibleContexts, FlexibleInstances, TypeSynonymInstances,+ LambdaCase, MultiParamTypeClasses, DeriveGeneric #-}++module JavaScript.Web.XMLHttpRequest ( xhr+ , xhrByteString+ , xhrText+ , xhrString+ , Method(..)+ , Request(..)+ , RequestData(..)+ , Response(..)+ , ResponseType(..)+ , FormDataVal(..)+ , XHRError(..)+ ) where++import Control.Applicative+import Control.Exception+import Control.Monad++import GHCJS.Types+import GHCJS.Prim+import GHCJS.Marshal+import GHCJS.Marshal.Pure+import GHCJS.Internal.Types++import qualified GHCJS.Buffer as Buffer++import GHC.Generics++import Data.ByteString+import Data.Data+import Data.JSString+import Data.JSString.Internal.Type ( JSString(..) )+import Data.Typeable+import Data.Proxy+import Data.Text (Text)++import Data.JSString.Text (textFromJSString)+import qualified Data.JSString as JSS++import JavaScript.JSON.Types.Internal ( SomeValue(..) )+import JavaScript.TypedArray.Internal.Types ( SomeTypedArray(..) )+import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer(..) )+import JavaScript.TypedArray.ArrayBuffer.Internal ( SomeArrayBuffer(..) )++import JavaScript.Web.Blob+import JavaScript.Web.Blob.Internal++import JavaScript.Web.File++data Method = GET | POST | PUT | DELETE+ deriving (Show, Eq, Ord, Enum)++data XHRError = XHRError String+ | XHRAborted+ deriving (Generic, Data, Typeable, Show, Eq) ++instance Exception XHRError++methodJSString :: Method -> JSString+methodJSString GET = "GET"+methodJSString POST = "POST"+methodJSString PUT = "PUT"+methodJSString DELETE = "DELETE"++type Header = (JSString, JSString)++data FormDataVal = StringVal JSString+ | BlobVal Blob (Maybe JSString)+ | FileVal File (Maybe JSString)+ deriving (Typeable)++data Request = Request { reqMethod :: Method+ , reqURI :: JSString+ , reqLogin :: Maybe (JSString, JSString)+ , reqHeaders :: [Header]+ , reqWithCredentials :: Bool+ , reqData :: RequestData+ }+ deriving (Typeable)++data RequestData = NoData+ | StringData JSString+ | TypedArrayData (forall e. SomeTypedArray e Immutable)+ | FormData [(JSString, FormDataVal)]+ deriving (Typeable)++data Response a = Response { contents :: Maybe a+ , status :: Int+ , getAllResponseHeaders :: IO JSString+ , getResponseHeader :: JSString -> IO (Maybe JSString)+ }++instance Functor Response where fmap f r = r { contents = fmap f (contents r) }++class ResponseType a where+ getResponseTypeString :: Proxy a -> JSString+ wrapResponseType :: JSVal -> a++instance ResponseType ArrayBuffer where+ getResponseTypeString _ = "arraybuffer"+ wrapResponseType = SomeArrayBuffer++instance m ~ Immutable => ResponseType JSString where+ getResponseTypeString _ = "text"+ wrapResponseType = JSString++instance ResponseType Blob where+ getResponseTypeString _ = "blob"+ wrapResponseType = SomeBlob++instance m ~ Immutable => ResponseType (SomeValue m) where+ getResponseTypeString _ = "json"+ wrapResponseType = SomeValue++newtype JSFormData = JSFormData JSVal deriving (Typeable)++newtype XHR = XHR JSVal deriving (Typeable)++-- -----------------------------------------------------------------------------+-- main entry point++xhr :: forall a. ResponseType a => Request -> IO (Response a)+xhr req = js_createXHR >>= \x ->+ let doRequest = do+ case reqLogin req of+ Nothing ->+ js_open2 (methodJSString (reqMethod req)) (reqURI req) x+ Just (user, pass) ->+ js_open4 (methodJSString (reqMethod req)) (reqURI req) user pass x+ js_setResponseType+ (getResponseTypeString (Proxy :: Proxy a)) x+ forM_ (reqHeaders req) (\(n,v) -> js_setRequestHeader n v x)+ + case reqWithCredentials req of+ True -> js_setWithCredentials x+ False -> return ()+ + r <- case reqData req of+ NoData ->+ js_send0 x+ StringData str ->+ js_send1 (pToJSVal str) x+ TypedArrayData (SomeTypedArray t) ->+ js_send1 t x+ FormData xs -> do+ fd@(JSFormData fd') <- js_createFormData+ forM_ xs $ \(name, val) -> case val of+ StringVal str ->+ js_appendFormData2 name (pToJSVal str) fd+ BlobVal (SomeBlob b) mbFile ->+ appendFormData name b mbFile fd+ FileVal (SomeBlob b) mbFile ->+ appendFormData name b mbFile fd+ js_send1 fd' x+ case r of+ 0 -> do+ status <- js_getStatus x+ r <- do+ hr <- js_hasResponse x+ if hr then Just . wrapResponseType <$> js_getResponse x+ else pure Nothing+ return $ Response r+ status+ (js_getAllResponseHeaders x)+ (\h -> getResponseHeader' h x)+ 1 -> throwIO XHRAborted+ 2 -> throwIO (XHRError "network request error")+ in doRequest `onException` js_abort x++appendFormData :: JSString -> JSVal+ -> Maybe JSString -> JSFormData -> IO ()+appendFormData name val Nothing fd =+ js_appendFormData2 name val fd+appendFormData name val (Just fileName) fd =+ js_appendFormData3 name val fileName fd++getResponseHeader' :: JSString -> XHR -> IO (Maybe JSString)+getResponseHeader' name x = do+ h <- js_getResponseHeader name x+ return $ if isNull h then Nothing else Just (JSString h)++-- -----------------------------------------------------------------------------+-- utilities++xhrString :: Request -> IO (Response String)+xhrString = fmap (fmap JSS.unpack) . xhr++xhrText :: Request -> IO (Response Text)+xhrText = fmap (fmap textFromJSString) . xhr++xhrByteString :: Request -> IO (Response ByteString)+xhrByteString = fmap+ (fmap (Buffer.toByteString 0 Nothing . Buffer.createFromArrayBuffer)) . xhr++-- -----------------------------------------------------------------------------++foreign import javascript unsafe+ "$1.withCredentials = true;"+ js_setWithCredentials :: XHR -> IO ()++foreign import javascript unsafe+ "new XMLHttpRequest()"+ js_createXHR :: IO XHR+foreign import javascript unsafe+ "$2.responseType = $1;"+ js_setResponseType :: JSString -> XHR -> IO ()+foreign import javascript unsafe+ "$1.abort();"+ js_abort :: XHR -> IO ()+foreign import javascript unsafe+ "$3.setRequestHeader($1,$2);"+ js_setRequestHeader :: JSString -> JSString -> XHR -> IO ()+foreign import javascript unsafe+ "$3.open($1,$2)"+ js_open2 :: JSString -> JSString -> XHR -> IO ()+foreign import javascript unsafe+ "$5.open($1,$2,true,$4,$5);"+ js_open4 :: JSString -> JSString -> JSString -> JSString -> XHR -> IO ()+foreign import javascript unsafe+ "new FormData()"+ js_createFormData :: IO JSFormData+foreign import javascript unsafe+ "$3.append($1,$2)"+ js_appendFormData2 :: JSString -> JSVal -> JSFormData -> IO ()+foreign import javascript unsafe+ "$4.append($1,$2,$3)"+ js_appendFormData3 :: JSString -> JSVal -> JSString -> JSFormData -> IO ()+foreign import javascript unsafe+ "$1.status"+ js_getStatus :: XHR -> IO Int+foreign import javascript unsafe+ "$1.response"+ js_getResponse :: XHR -> IO JSVal+foreign import javascript unsafe+ "$1.response ? true : false"+ js_hasResponse :: XHR -> IO Bool+foreign import javascript unsafe+ "$1.getAllResponseHeaders()"+ js_getAllResponseHeaders :: XHR -> IO JSString+foreign import javascript unsafe+ "$2.getResponseHeader($1)"+ js_getResponseHeader :: JSString -> XHR -> IO JSVal++-- -----------------------------------------------------------------------------++foreign import javascript interruptible+ "h$sendXHR($1, null, $c);"+ js_send0 :: XHR -> IO Int+foreign import javascript interruptible+ "h$sendXHR($2, $1, $c);"+ js_send1 :: JSVal -> XHR -> IO Int
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright (c) 2013 Luite Stegeman++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghcjs-base.cabal view
@@ -0,0 +1,175 @@+name: ghcjs-base+version: 0.2.0.0+synopsis: base library for GHCJS+homepage: http://github.com/ghcjs/ghcjs-base+license: MIT+license-file: LICENSE+author: Luite Stegeman+maintainer: stegeman@gmail.com+category: Web+build-type: Simple+cabal-version: >=1.8++library+ js-sources: jsbits/array.js+ jsbits/animationFrame.js+ jsbits/export.js+ jsbits/jsstring.js+ jsbits/jsstringRaw.js+ jsbits/foreign.js+ jsbits/text.js+ jsbits/utils.js+ jsbits/xhr.js+ jsbits/websocket.js+ other-extensions: DeriveDataTypeable+ DeriveGeneric+ ForeignFunctionInterface+ JavaScriptFFI+ GHCForeignImportPrim+ MagicHash+ UnboxedTuples+ TypeFamilies+ CPP+ UnliftedFFITypes+ BangPatterns+ ScopedTypeVariables+ FlexibleInstances+ TypeSynonymInstances+ ViewPatterns+-- NegativeLiterals+-- fixme do we need negativeliterals?+ DefaultSignatures+ EmptyDataDecls+ OverloadedStrings+ Rank2Types+ ExistentialQuantification+ GeneralizedNewtypeDeriving+ ScopedTypeVariables+ TypeOperators++ exposed-modules: Data.JSString+ Data.JSString.Int+ Data.JSString.Raw+ Data.JSString.Read+ Data.JSString.RealFloat+ Data.JSString.RegExp+ Data.JSString.Internal+ Data.JSString.Text+ Data.JSString.Internal.Fusion+ Data.JSString.Internal.Fusion.Types+ Data.JSString.Internal.Fusion.Common+ Data.JSString.Internal.Fusion.CaseMapping+ Data.JSString.Internal.Search+ GHCJS.Buffer+ GHCJS.Buffer.Types+ GHCJS.Concurrent+ GHCJS.Foreign+ GHCJS.Foreign.Callback+ GHCJS.Foreign.Callback.Internal+ GHCJS.Foreign.Export+ GHCJS.Foreign.Internal+ GHCJS.Marshal+ GHCJS.Marshal.Internal+ GHCJS.Marshal.Pure+ GHCJS.Nullable+ GHCJS.Types+ JavaScript.Array+ JavaScript.Array.Internal+ JavaScript.Array.ST+ JavaScript.Cast+ JavaScript.JSON+ JavaScript.JSON.Types+ JavaScript.JSON.Types.Class+ JavaScript.JSON.Types.Generic+ JavaScript.JSON.Types.Instances+ JavaScript.JSON.Types.Internal+ JavaScript.Number+ JavaScript.Object+ JavaScript.Object.Internal+ JavaScript.RegExp+ JavaScript.TypedArray+ JavaScript.TypedArray.ArrayBuffer+ JavaScript.TypedArray.ArrayBuffer.ST+ JavaScript.TypedArray.DataView+ JavaScript.TypedArray.DataView.ST+ JavaScript.TypedArray.Internal+ JavaScript.TypedArray.ST+ JavaScript.Web.AnimationFrame+ JavaScript.Web.Blob+ JavaScript.Web.Blob.Internal+ JavaScript.Web.Canvas+ JavaScript.Web.Canvas.ImageData+ JavaScript.Web.Canvas.Internal+ JavaScript.Web.Canvas.TextMetrics+ JavaScript.Web.CloseEvent+ JavaScript.Web.CloseEvent.Internal+ JavaScript.Web.ErrorEvent+ JavaScript.Web.ErrorEvent.Internal+ JavaScript.Web.File+ JavaScript.Web.History+ JavaScript.Web.Location+ JavaScript.Web.MessageEvent+ JavaScript.Web.MessageEvent.Internal+ JavaScript.Web.Performance+ JavaScript.Web.Storage+ JavaScript.Web.Storage.Internal+ JavaScript.Web.StorageEvent+ JavaScript.Web.XMLHttpRequest+ JavaScript.Web.WebSocket+ JavaScript.Web.Worker+ other-modules: GHCJS.Internal.Types+ Data.JSString.Internal.Type+ JavaScript.TypedArray.Internal.Types+ JavaScript.TypedArray.ArrayBuffer.Internal+ JavaScript.TypedArray.DataView.Internal+ build-depends: base >= 4.7 && < 5,+ ghc-prim,+ ghcjs-prim,+ integer-gmp,+ binary >= 0.8 && < 0.11,+ bytestring >= 0.10 && < 0.11,+ text >= 1.1 && < 1.3,+ aeson >= 0.8 && < 1.5,+ scientific >= 0.3 && < 0.4,+ vector >= 0.10 && < 0.13,+ containers >= 0.5 && < 0.7,+ time >= 1.5 && < 1.9,+ hashable >= 1.2 && < 1.3,+ unordered-containers >= 0.2 && < 0.3,+ attoparsec >= 0.11 && < 0.14,+ transformers >= 0.3 && < 0.6,+ primitive >= 0.5 && < 0.7,+ deepseq >= 1.3 && < 1.5,+ dlist >= 0.7 && < 0.9++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Tests.hs+ other-modules: Tests.Marshal+ Tests.Properties+ Tests.Properties.Numeric+ Tests.SlowFunctions+ Tests.QuickCheckUtils+ Tests.Regressions+ Tests.Utils+ ghc-options:+ -Wall -rtsopts+ build-depends:+ HUnit >= 1.2,+ QuickCheck >= 2.7,+ array,+ text,+ base,+ bytestring,+ deepseq,+ directory,+ ghc-prim,+ ghcjs-prim,+ ghcjs-base,+ primitive,+ quickcheck-unicode,+ random,+ test-framework >= 0.4,+ test-framework-hunit >= 0.2,+ test-framework-quickcheck2 >= 0.2
+ jsbits/animationFrame.js view
@@ -0,0 +1,18 @@+function h$animationFrameCancel(h) {+ if(h.handle) window.cancelAnimationFrame(h.handle);+ if(h.callback) {+ h$release(h.callback)+ h.callback = null;+ }+}++function h$animationFrameRequest(h) {+ h.handle = window.requestAnimationFrame(function(ts) {+ var cb = h.callback;+ if(cb) {+ h$release(cb);+ h.callback = null;+ cb(ts);+ }+ });+}
+ jsbits/array.js view
@@ -0,0 +1,40 @@+#include <ghcjs/rts.h>++/*+ convert an array to a Haskell list, wrapping each element in a+ JSVal constructor+ */+function h$fromArray(a) {+ var r = HS_NIL;+ for(var i=a.length-1;i>=0;i--) r = MK_CONS(MK_JSVAL(a[i]), r);+ return a;+}++/*+ convert an array to a Haskell list. No additional wrapping of the+ elements is performed. Only use this when the elements are directly+ usable as Haskell heap objects (numbers, boolean) or when the+ array elements have already been appropriately wrapped+ */+function h$fromArrayNoWrap(a) {+ var r = HS_NIL;+ for(var i=a.length-1;i>=0;i--) r = MK_CONS(a[i], r);+ return a;+}++/*+ convert a list of JSVal to an array. the list must have been fully forced,+ not just the spine.+ */+function h$listToArray(xs) {+ var a = [], i = 0;+ while(IS_CONS(xs)) {+ a[i++] = JSVAL_VAL(CONS_HEAD(xs));+ xs = CONS_TAIL(xs);+ }+ return a;+}++function h$listToArrayWrap(xs) {+ return MK_JSVAL(h$listToArray(xs));+}
+ jsbits/export.js view
@@ -0,0 +1,26 @@+function h$exportValue(fp1a,fp1b,fp2a,fp2b,o) {+ var e = { fp1a: fp1a+ , fp1b: fp1b+ , fp2a: fp2a+ , fp2b: fp2b+ , released: false+ , root: o+ , _key: -1+ };+ h$retain(e);+ return e;+}++function h$derefExport(fp1a,fp1b,fp2a,fp2b,e) {+ if(!e || typeof e !== 'object') return null;+ if(e.released) return null;+ if(fp1a !== e.fp1a || fp1b !== e.fp1b ||+ fp2a !== e.fp2a || fp2b !== e.fp2b) return null;+ return e.root;+}++function h$releaseExport(e) {+ h$release(e);+ e.released = true;+ e.root = null;+}
+ jsbits/foreign.js view
@@ -0,0 +1,8 @@+function h$foreignListProps(o) {+ var r = HS_NIL;+ if(typeof o === 'undefined' || o === null) return null;+ throw "h$foreignListProps";+/* for(var p in o) {++ } */+}
+ jsbits/jsstring.js view
@@ -0,0 +1,1181 @@+#include <ghcjs/rts.h>++/*+ * Support code for the Data.JSString module. This code presents a JSString+ * as a sequence of code points and hides the underlying encoding ugliness of+ * the JavaScript strings.+ *+ * Use Data.JSString.Raw for direct access to the JSThis makes the operations more expen+ */++/*+ * Some workarounds here for JS engines that do not support proper+ * code point access+ */++#ifdef GHCJS_TRACE_JSSTRING+#define TRACE_JSSTRING(args...) h$log("jsstring: ", args);+#else+#define TRACE_JSSTRING(args...)+#endif++#define IS_ASTRAL(cp) ((cp)>=0x10000)+#define IS_HI_SURR(cp) ((cp|1023)===0xDBFF)+#define IS_LO_SURR(cp) ((cp|1023)===0xDFFF)+#define FROM_SURR(hi,lo) ((((hi)-0xD800)<<10)+(lo)-0xDC00+0x10000)+#define HI_SURR(cp) ((((cp)-0x10000)>>>10)+0xDC00)+#define LO_SURR(cp) (((cp)&0x3FF)+0xD800)++var h$jsstringEmpty = MK_JSVAL('');++var h$jsstringHead, h$jsstringTail, h$jsstringCons,+ h$jsstringSingleton, h$jsstringSnoc, h$jsstringUncons,+ h$jsstringIndex, h$jsstringUncheckedIndex;++var h$fromCodePoint;++if(String.prototype.fromCodePoint) {+ h$fromCodePoint = String.fromCodePoint;+} else {+ // polyfill from https://github.com/mathiasbynens/String.fromCodePoint (MIT-license)+ h$fromCodePoint =+ (function() {+ var stringFromCharCode = String.fromCharCode;+ var floor = Math.floor;+ return function(_) {+ var MAX_SIZE = 0x4000;+ var codeUnits = [];+ var highSurrogate;+ var lowSurrogate;+ var index = -1;+ var length = arguments.length;+ if (!length) {+ return '';+ }+ var result = '';+ while (++index < length) {+ var codePoint = Number(arguments[index]);+ if (+ !isFinite(codePoint) || // `NaN`, `+Infinity`, or `-Infinity`+ codePoint < 0 || // not a valid Unicode code point+ codePoint > 0x10FFFF || // not a valid Unicode code point+ floor(codePoint) != codePoint // not an integer+ ) {+ throw RangeError('Invalid code point: ' + codePoint);+ }+ if (codePoint <= 0xFFFF) { // BMP code point+ codeUnits.push(codePoint);+ } else { // Astral code point; split in surrogate halves+ // https://mathiasbynens.be/notes/javascript-encoding#surrogate-formulae+ codePoint -= 0x10000;+ highSurrogate = (codePoint >> 10) + 0xD800;+ lowSurrogate = (codePoint % 0x400) + 0xDC00;+ codeUnits.push(highSurrogate, lowSurrogate);+ }+ if (index + 1 == length || codeUnits.length > MAX_SIZE) {+ result += stringFromCharCode.apply(null, codeUnits);+ codeUnits.length = 0;+ }+ }+ return result;+ }+ })();+}++if(String.prototype.codePointAt) {+ h$jsstringSingleton = function(ch) {+ TRACE_JSSTRING("(codePointAt) singleton: " + ch);+ return String.fromCodePoint(ch);+ }+ h$jsstringHead = function(str) {+ TRACE_JSSTRING("(codePointAt) head: " + str);+ var cp = str.codePointAt(0);+ return (cp === undefined) ? -1 : (cp|0);+ }+ h$jsstringTail = function(str) {+ TRACE_JSSTRING("(codePointAt) tail: " + str);+ var l = str.length;+ if(l===0) return null;+ var ch = str.codePointAt(0);+ if(ch === undefined) return null;+ // string length is at least two if ch comes from a surrogate pair+ return str.substr(IS_ASTRAL(ch)?2:1);+ }+ h$jsstringCons = function(ch, str) {+ TRACE_JSSTRING("(codePointAt) cons: " + ch + " '" + str + "'");+ return String.fromCodePoint(ch)+str;+ }+ h$jsstringSnoc = function(str, ch) {+ TRACE_JSSTRING("(codePointAt) snoc: '" + str + "' " + ch);+ return str+String.fromCodePoint(ch);+ }+ h$jsstringUncons = function(str) {+ TRACE_JSSTRING("(codePointAt) uncons: '" + str + "'");+ var l = str.length;+ if(l===0) {+ RETURN_UBX_TUP2(-1, null);+ }+ var ch = str.codePointAt(0);+ if(ch === undefined) {+ RETURN_UBX_TUP2(-1, null);+ }+ RETURN_UBX_TUP2(ch, str.substr(IS_ASTRAL(ch)?2:1));+ }+ // index is the first part of the character+ h$jsstringIndex = function(i, str) {+ TRACE_JSSTRING("(codePointAt) index: " + i + " '" + str + "'");+ var ch = str.codePointAt(i);+ if(ch === undefined) return -1;+ return ch;+ }+ h$jsstringUncheckedIndex = function(i, str) {+ TRACE_JSSTRING("(codePointAt) uncheckedIndex: " + i + " '" + str.length + "'");+ return str.codePointAt(i);+ }+} else {+ h$jsstringSingleton = function(ch) {+ TRACE_JSSTRING("(no codePointAt) singleton: " + ch);+ return (IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch))+ : String.fromCharCode(ch);+ }+ h$jsstringHead = function(str) {+ TRACE_JSSTRING("(no codePointAt) head: " + str);+ var l = str.length;+ if(l===0) return -1;+ var ch = str.charCodeAt(0);+ if(IS_HI_SURR(ch)) {+ return (l>1) ? FROM_SURR(ch, str.charCodeAt(1)) : -1;+ } else {+ return ch;+ }+ }+ h$jsstringTail = function(str) {+ TRACE_JSSTRING("(no codePointAt) tail: " + str);+ var l = str.length;+ if(l===0) return null;+ var ch = str.charCodeAt(0);+ if(IS_HI_SURR(ch)) {+ return (l>1)?str.substr(2):null;+ } else return str.substr(1);+ }+ h$jsstringCons = function(ch, str) {+ TRACE_JSSTRING("(no codePointAt) cons: " + ch + " '" + str + "'");+ return ((IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch))+ : String.fromCharCode(ch))+ + str;+ }+ h$jsstringSnoc = function(str, ch) {+ TRACE_JSSTRING("(no codePointAt) snoc: '" + str + "' " + ch);+ return str + ((IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch))+ : String.fromCharCode(ch));+ }+ h$jsstringUncons = function(str) {+ TRACE_JSSTRING("(no codePointAt) uncons: '" + str + "'");+ var l = str.length;+ if(l===0) {+ RETURN_UBX_TUP2(-1, null);+ }+ var ch = str.charCodeAt(0);+ if(IS_HI_SURR(ch)) {+ if(l > 1) {+ RETURN_UBX_TUP2(FROM_SURR(ch, str.charCodeAt(1)), str.substr(2));+ } else {+ RETURN_UBX_TUP2(-1, null);+ }+ } else {+ RETURN_UBX_TUP2(ch, str.substr(1));+ }+ }+ // index is the first part of the character+ h$jsstringIndex = function(i, str) {+ // TRACE_JSSTRING("(no codePointAt) index: " + i + " '" + str + "'");+ var ch = str.charCodeAt(i);+ if(ch != ch) return -1; // NaN test+ return (IS_HI_SURR(ch)) ? FROM_SURR(ch, str.charCodeAt(i+1)) : ch;+ }+ h$jsstringUncheckedIndex = function(i, str) {+ TRACE_JSSTRING("(no codePointAt) uncheckedIndex: " + i + " '" + str.length + "'");+ var ch = str.charCodeAt(i);+ return (IS_HI_SURR(ch)) ? FROM_SURR(ch, str.charCodeAt(i+1)) : ch;+ }+}++function h$jsstringUnsnoc(str) {+ TRACE_JSSTRING("unsnoc: '" + str + "'");+ var l = str.length;+ if(l===0) {+ RETURN_UBX_TUP2(-1, null);+ }+ var ch = str.charCodeAt(l-1);+ if(IS_LO_SURR(ch)) {+ if(l !== 1) {+ RETURN_UBX_TUP2(FROM_SURR(str.charCodeAt(l-2),ch), str.substr(0,l-2));+ } else {+ RETURN_UBX_TUP2(-1, null);+ }+ } else {+ RETURN_UBX_TUP2(ch, str.substr(0,l-1));+ }+}+++function h$jsstringPack(xs) {+ var r = '', i = 0, a = [], c;+ while(IS_CONS(xs)) {+ c = CONS_HEAD(xs);+ a[i++] = UNWRAP_NUMBER(c);+ if(i >= 60000) {+ r += h$fromCodePoint.apply(null, a);+ a = [];+ i = 0;+ }+ xs = CONS_TAIL(xs);+ }+ if(i > 0) r += h$fromCodePoint.apply(null, a);+ TRACE_JSSTRING("pack: '" + r + "'");+ return r;+}++function h$jsstringPackReverse(xs) {+ var a = [], i = 0, c;+ while(IS_CONS(xs)) {+ c = CONS_HEAD(xs);+ a[i++] = UNWRAP_NUMBER(c);+ xs = CONS_TAIL(xs);+ }+ if(i===0) return '';+ var r = h$jsstringConvertArray(a.reverse());+ TRACE_JSSTRING("packReverse: '" + r + "'");+ return r;+}++function h$jsstringPackArray(arr) {+ TRACE_JSSTRING("pack array: " + arr);+ return h$jsstringConvertArray(arr);+}++function h$jsstringPackArrayReverse(arr) {+ TRACE_JSSTRING("pack array reverse: " + arr);+ return h$jsstringConvertArray(arr.reverse());+}++function h$jsstringConvertArray(arr) {+ if(arr.length < 60000) {+ return h$fromCodePoint.apply(null, arr);+ } else {+ var r = '';+ for(var i=0; i<arr.length; i+=60000) {+ r += h$fromCodePoint.apply(null, arr.slice(i, i+60000));+ }+ return r;+ }+}++function h$jsstringInit(str) {+ TRACE_JSSTRING("init: '" + str + "'");+ var l = str.length;+ if(l===0) return null;+ var ch = str.charCodeAt(l-1);+ var o = IS_LO_SURR(ch)?2:1;+ var r = str.substr(0, l-o);+ return r;+}++function h$jsstringLast(str) {+ TRACE_JSSTRING("last: '" + str + "'");+ var l = str.length;+ if(l===0) return -1;+ var ch = str.charCodeAt(l-1);+ if(IS_LO_SURR(ch)) {+ return (l>1) ? FROM_SURR(str.charCodeAt(l-2), ch) : -1;++ } else return ch;+}++// index is the last part of the character+function h$jsstringIndexR(i, str) {+ TRACE_JSSTRING("indexR: " + i + " '" + str + "'");+ if(i < 0 || i > str.length) return -1;+ var ch = str.charCodeAt(i);+ return (IS_LO_SURR(ch)) ? FROM_SURR(str.charCodeAt(i-1), ch) : ch;+}++function h$jsstringNextIndex(i, str) {+ TRACE_JSSTRING("nextIndex: " + i + " '" + str + "'");+ return i + (IS_HI_SURR(str.charCodeAt(i))?2:1);+}++function h$jsstringTake(n, str) {+ TRACE_JSSTRING("take: " + n + " '" + str + "'");+ if(n <= 0) return '';+ var i = 0, l = str.length, ch;+ if(n >= l) return str;+ while(n--) {+ ch = str.charCodeAt(i++);+ if(IS_HI_SURR(ch)) i++;+ if(i >= l) return str;+ }+ return str.substr(0,i);+}++function h$jsstringDrop(n, str) {+ TRACE_JSSTRING("drop: " + n + " '" + str + "'");+ if(n <= 0) return str;+ var i = 0, l = str.length, ch;+ if(n >= l) return '';+ while(n--) {+ ch = str.charCodeAt(i++);+ if(IS_HI_SURR(ch)) i++;+ if(i >= l) return '';+ }+ return str.substr(i);+}++function h$jsstringSplitAt(n, str) {+ TRACE_JSSTRING("splitAt: " + n + " '" + str + "'");+ if(n <= 0) {+ RETURN_UBX_TUP2("", str);+ } else if(n >= str.length) {+ RETURN_UBX_TUP2(str, "");+ }+ var i = 0, l = str.length, ch;+ while(n--) {+ ch = str.charCodeAt(i++);+ if(IS_HI_SURR(ch)) i++;+ if(i >= l) {+ RETURN_UBX_TUP2(str, "");+ }+ }+ RETURN_UBX_TUP2(str.substr(0,i),str.substr(i));+}++function h$jsstringTakeEnd(n, str) {+ TRACE_JSSTRING("takeEnd: " + n + " '" + str + "'");+ if(n <= 0) return '';+ var l = str.length, i = l-1, ch;+ if(n >= l) return str;+ while(n-- && i > 0) {+ ch = str.charCodeAt(i--);+ if(IS_LO_SURR(ch)) i--;+ }+ return (i<0) ? str : str.substr(i+1);+}++function h$jsstringDropEnd(n, str) {+ TRACE_JSSTRING("dropEnd: " + n + " '" + str + "'");+ if(n <= 0) return str;+ var l = str.length, i = l-1, ch;+ if(n >= l) return '';+ while(n-- && i > 0) {+ ch = str.charCodeAt(i--);+ if(IS_LO_SURR(ch)) i--;+ }+ return (i<0) ? '' : str.substr(0,i+1);+}++function h$jsstringIntercalate(x, ys) {+ TRACE_JSSTRING("intercalate: '" + x + "'");+ var a = [], i = 0;+ while(IS_CONS(ys)) {+ if(i) a[i++] = x;+ a[i++] = JSVAL_VAL(CONS_HEAD(ys));+ ys = CONS_TAIL(ys);+ }+ return a.join('');+}++function h$jsstringIntersperse(ch, ys) {+ TRACE_JSSTRING("intersperse: " + ch + " '" + ys + "'");+ var i = 0, l = ys.length, j = 0, a = [], ych;+ if(IS_ASTRAL(ch)) {+ while(j < l) {+ if(i) a[i++] = ch;+ ych = ys.charCodeAt(j++);+ a[i++] = ych;+ if(IS_HI_SURR(ych)) a[i++] = ys.charCodeAt(j++);+ }+ } else {+ while(j < l) {+ if(i) a[i++] = ch;+ ych = ys.charCodeAt(j++);+ a[i++] = ych;+ if(IS_HI_SURR(ych)) a[i++] = ys.charCodeAt(j++);+ }+ }+ return h$jsstringConvertArray(a);+}++function h$jsstringConcat(xs) {+ TRACE_JSSTRING("concat");+ var a = [], i = 0;+ while(IS_CONS(xs)) {+ a[i++] = JSVAL_VAL(CONS_HEAD(xs));+ xs = CONS_TAIL(xs);+ }+ return a.join('');+}++var h$jsstringStripPrefix, h$jsstringStripSuffix,+ h$jsstringIsPrefixOf, h$jsstringIsSuffixOf,+ h$jsstringIsInfixOf;+if(String.prototype.startsWith) {+ h$jsstringStripPrefix = function(p, x) {+ TRACE_JSSTRING("(startsWith) stripPrefix: '" + p + "' '" + x + "'");+ if(x.startsWith(p)) {+ return MK_JUST(MK_JSVAL(x.substr(p.length)));+ } else {+ return HS_NOTHING;+ }+ }++ h$jsstringIsPrefixOf = function(p, x) {+ TRACE_JSSTRING("(startsWith) isPrefixOf: '" + p + "' '" + x + "'");+ return x.startsWith(p);+ }++} else {+ h$jsstringStripPrefix = function(p, x) {+ TRACE_JSSTRING("(no startsWith) stripPrefix: '" + p + "' '" + x + "'");+ if(x.indexOf(p) === 0) { // this has worse complexity than it should+ return MK_JUST(MK_JSVAL(x.substr(p.length)));+ } else {+ return HS_NOTHING;+ }+ }++ h$jsstringIsPrefixOf = function(p, x) {+ TRACE_JSSTRING("(no startsWith) isPrefixOf: '" + p + "' '" + x + "'");+ return x.indexOf(p) === 0; // this has worse complexity than it should+ }+}++if(String.prototype.endsWith) {+ h$jsstringStripSuffix = function(s, x) {+ TRACE_JSSTRING("(endsWith) stripSuffix: '" + s + "' '" + x + "'");+ if(x.endsWith(s)) {+ return MK_JUST(MK_JSVAL(x.substr(0,x.length-s.length)));+ } else {+ return HS_NOTHING;+ }+ }++ h$jsstringIsSuffixOf = function(s, x) {+ TRACE_JSSTRING("(endsWith) isSuffixOf: '" + s + "' '" + x + "'");+ return x.endsWith(s);+ }+} else {+ h$jsstringStripSuffix = function(s, x) {+ TRACE_JSSTRING("(no endsWith) stripSuffix: '" + s + "' '" + x + "'");+ var i = x.lastIndexOf(s); // this has worse complexity than it should+ var l = x.length - s.length;+ if(i !== -1 && i === l) {+ return MK_JUST(MK_JSVAL(x.substr(0,l)));+ } else {+ return HS_NOTHING;+ }+ }++ h$jsstringIsSuffixOf = function(s, x) {+ TRACE_JSSTRING("(no endsWith) isSuffixOf: '" + s + "' '" + x + "'");+ var i = x.lastIndexOf(s); // this has worse complexity than it should+ return i !== -1 && i === x.length - s.length;+ }+}++if(String.prototype.includes) {+ h$jsstringIsInfixOf = function(i, x) {+ TRACE_JSSTRING("(includes) isInfixOf: '" + i + "' '" + x + "'");+ return x.includes(i);+ }+} else {+ h$jsstringIsInfixOf = function(i, x) {+ TRACE_JSSTRING("(no includes) isInfixOf: '" + i + "' '" + x + "'");+ return x.indexOf(i) !== -1; // this has worse complexity than it should+ }+}++function h$jsstringCommonPrefixes(x, y) {+ TRACE_JSSTRING("commonPrefixes: '" + x + "' '" + y + "'");+ var lx = x.length, ly = y.length, i = 0, cx;+ var l = lx <= ly ? lx : ly;+ if(lx === 0 || ly === 0 || x.charCodeAt(0) !== y.charCodeAt(0)) {+ return HS_NOTHING;+ }+ while(++i<l) {+ cx = x.charCodeAt(i);+ if(cx !== y.charCodeAt(i)) {+ if(IS_LO_SURR(cx)) i--;+ break;+ }+ }+ if(i===0) return HS_NOTHING;+ return MK_JUST(MK_TUP3( MK_JSVAL((i===lx)?x:((i===ly)?y:x.substr(0,i)))+ , (i===lx) ? h$jsstringEmpty : MK_JSVAL(x.substr(i))+ , (i===ly) ? h$jsstringEmpty : MK_JSVAL(y.substr(i))+ ));+}++function h$jsstringBreakOn(b, x) {+ TRACE_JSSTRING("breakOn: '" + b + "' '" + x + "'");+ var i = x.indexOf(b);+ if(i===-1) {+ RETURN_UBX_TUP2(x, "");+ }+ if(i===0) {+ RETURN_UBX_TUP2("", x);+ }+ RETURN_UBX_TUP2(x.substr(0,i), x.substr(i));+}++function h$jsstringBreakOnEnd(b, x) {+ TRACE_JSSTRING("breakOnEnd: '" + b + "' '" + x + "'");+ var i = x.lastIndexOf(b);+ if(i===-1) {+ RETURN_UBX_TUP2("", x);++ }+ i += b.length;+ RETURN_UBX_TUP2(x.substr(0,i), x.substr(i));+}++function h$jsstringBreakOnAll1(n, b, x) {+ TRACE_JSSTRING("breakOnAll1: " + n + " '" + b + "' '" + x + "'");+ var i = x.indexOf(b, n);+ if(i===0) {+ RETURN_UBX_TUP3(b.length, "", x);+ }+ if(i===-1) {+ RETURN_UBX_TUP3(-1, null, null);+ }+ RETURN_UBX_TUP3(i+b.length, x.substr(0,i), x.substr(i));+}++function h$jsstringBreakOnAll(pat, src) {+ TRACE_JSSTRING("breakOnAll");+ var a = [], i = 0, n = 0, r = HS_NIL, pl = pat.length;+ while(true) {+ var x = src.indexOf(pat, n);+ if(x === -1) break;+ a[i++] = MK_TUP2(MK_JSVAL(src.substr(0,x)), MK_JSVAL(src.substr(x)));+ n = x + pl;+ }+ while(--i >= 0) r = MK_CONS(a[i], r);+ return r;+}++function h$jsstringSplitOn1(n, p, x) {+ TRACE_JSSTRING("splitOn1: " + n + " '" + p + "' '" + x + "'");+ var i = x.indexOf(p, n);+ if(i === -1) {+ RETURN_UBX_TUP2(-1, null);+ }+ var r1 = (i==n) ? "" : x.substr(n, i-n);+ RETURN_UBX_TUP2(i + p.length, r1);+}++function h$jsstringSplitOn(p, x) {+ TRACE_JSSTRING("splitOn: '" + p + "' '" + x + "'");+ var a = x.split(p);+ var r = HS_NIL, i = a.length;+ while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r);+ return r;+}++// returns -1 for end of input, start of next token otherwise+// word in h$ret1+// this function assumes that there are no whitespace characters >= 0x10000+function h$jsstringWords1(n, x) {+ TRACE_JSSTRING("words1: " + n + " '" + x + "'");+ var m = n, s = n, l = x.length;+ if(m >= l) return -1;+ // skip leading spaces+ do {+ if(m >= l) return -1;+ } while(h$isSpace(x.charCodeAt(m++)));+ // found start of word+ s = m - 1;+ while(m < l) {+ if(h$isSpace(x.charCodeAt(m++))) {+ // found end of word+ var r1 = (m-s<=1) ? "" : x.substr(s,m-s-1);+ RETURN_UBX_TUP2(m, r1);+ }+ }+ // end of string+ if(s < l) {+ var r1 = s === 0 ? x : x.substr(s);+ RETURN_UBX_TUP2(m, r1);+ }+ RETURN_UBX_TUP2(-1, null);+}++function h$jsstringWords(x) {+ TRACE_JSSTRING("words: '" + x + "'");+ var a = null, i = 0, n, s = -1, m = 0, w, l = x.length, r = HS_NIL;+ outer:+ while(m < l) {+ // skip leading spaces+ do {+ if(m >= l) { s = m; break outer; }+ } while(h$isSpace(x.charCodeAt(m++)));+ // found start of word+ s = m - 1;+ while(m < l) {+ if(h$isSpace(x.charCodeAt(m++))) {+ // found end of word+ w = (m-s<=1) ? h$jsstringEmpty+ : MK_JSVAL(x.substr(s,m-s-1));+ if(i) a[i++] = w; else { a = [w]; i = 1; }+ s = m;+ break;+ }+ }+ }+ // end of string+ if(s !== -1 && s < l) {+ w = MK_JSVAL(s === 0 ? x : x.substr(s));+ if(i) a[i++] = w; else { a = [w]; i = 1; }+ }+ // build resulting list+ while(--i>=0) r = MK_CONS(a[i], r);+ return r;+}++// returns -1 for end of input, start of next token otherwise+// line in h$ret1+function h$jsstringLines1(n, x) {+ TRACE_JSSTRING("lines1: " + n + " '" + x + "'");+ var m = n, l = x.length;+ if(n >= l) return -1;+ while(m < l) {+ if(x.charCodeAt(m++) === 10) {+ // found newline+ if(n > 0 && n === l-1) return -1; // it was the last character+ var r1 = (m-n<=1) ? "" : x.substr(n,m-n-1);+ RETURN_UBX_TUP2(m, r1);+ }+ }+ // end of string+ RETURN_UBX_TUP2(m, x.substr(n));+}++function h$jsstringLines(x) {+ TRACE_JSSTRING("lines: '" + x + "'");+ var a = null, m = 0, i = 0, l = x.length, s = 0, r = HS_NIL, w;+ if(l === 0) return HS_NIL;+ outer:+ while(true) {+ s = m;+ do {+ if(m >= l) break outer;+ } while(x.charCodeAt(m++) !== 10);+ w = (m-s<=1) ? h$jsstringEmpty : MK_JSVAL(x.substr(s,m-s-1));+ if(i) a[i++] = w; else { a = [w]; i = 1; }+ }+ if(s < l) {+ w = MK_JSVAL(x.substr(s));+ if(i) a[i++] = w; else { a = [w]; i = 1; }+ }+ while(--i>=0) r = MK_CONS(a[i], r);+ return r;+}++function h$jsstringGroup(x) {+ TRACE_JSSTRING("group: '" + x + "'");+ var xl = x.length;+ if(xl === 0) return HS_NIL;+ var i = xl-1, si, ch, s=xl, r=HS_NIL;+ var tch = x.charCodeAt(i--);+ if(IS_LO_SURR(tch)) tch = FROM_SURR(x.charCodeAt(i--), tch);+ while(i >= 0) {+ si = i;+ ch = x.charCodeAt(i--);+ if(IS_LO_SURR(ch)) {+ ch = FROM_SURR(x.charCodeAt(i--), ch);+ }+ if(ch != tch) {+ tch = ch;+ r = MK_CONS(MK_JSVAL(x.substr(si+1,s-si)), r);+ s = si;+ }+ }+ return MK_CONS(MK_JSVAL(x.substr(0,s+1)), r);+}++function h$jsstringChunksOf1(n, s, x) {+ TRACE_JSSTRING("chunksOf1: " + n + " " + s + " '" + x + "'");+ var m = s, c = 0, l = x.length, ch;+ if(n <= 0 || l === 0 || s >= l) return -1+ while(++m < l) {+ ch = x.charCodeAt(m - 1);+ if(IS_HI_SURR(ch)) ++m;+ if(++c >= n) break;+ }+ var r1 = (m >= l && s === c) ? x : x.substr(s,m-s);+ RETURN_UBX_TUP2(m, r1);+}++function h$jsstringChunksOf(n, x) {+ TRACE_JSSTRING("chunksOf: " + n + " '" + x + "'");+ var l = x.length;+ if(l===0 || n <= 0) return HS_NIL;+ if(l <= n) return MK_CONS(MK_JSVAL(x), HS_NIL);+ var a = [], i = 0, s = 0, ch, m = 0, c, r = HS_NIL;+ while(m < l) {+ s = m;+ c = 0;+ while(m < l && ++c <= n) {+ ch = x.charCodeAt(m++);+ if(IS_HI_SURR(ch)) ++m;+ }+ if(c) a[i++] = x.substr(s, m-s);+ }+ while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r);+ return r;+}++function h$jsstringCount(pat, src) {+ TRACE_JSSTRING("count: '" + pat + "' '" + src + "'");+ var i = 0, n = 0, pl = pat.length, sl = src.length;+ while(i<sl) {+ i = src.indexOf(pat, i);+ if(i===-1) break;+ n++;+ i += pl;+ }+ return n;+}++function h$jsstringReplicate(n, str) {+ TRACE_JSSTRING("replicate: " + n + " '" + str + "'");+ if(n === 0 || str == '') return '';+ if(n === 1) return str;+ var r = '';+ do {+ if(n&1) r+=str;+ str+=str;+ n >>= 1;+ } while(n > 1);+ return r+str;+}++// this does not deal with combining diacritics, Data.Text does not either+var h$jsstringReverse;+if(Array.from) {+ h$jsstringReverse = function(str) {+ TRACE_JSSTRING("(Array.from) reverse: '" + str + "'");+ return Array.from(str).reverse().join('');+ }+} else {+ h$jsstringReverse = function(str) {+ TRACE_JSSTRING("(no Array.from) reverse: '" + str + "'");+ var l = str.length, a = [], o = 0, i = 0, c, c1, s = '';+ while(i < l) {+ c = str.charCodeAt(i);+ if(IS_HI_SURR(c)) {+ a[i] = str.charCodeAt(i+1);+ a[i+1] = c;+ i += 2;+ } else a[i++] = c;+ if(i-o > 60000) {+ s = String.fromCharCode.apply(null, a.reverse()) + s;+ o = -i;+ a = [];+ }+ }+ return (i===0) ? s : String.fromCharCode.apply(null,a.reverse()) + s;+ }+}++function h$jsstringUnpack(str) {+ TRACE_JSSTRING("unpack: '" + str + "'");+ var r = HS_NIL, i = str.length-1, c;+ while(i >= 0) {+ c = str.charCodeAt(i--);+ if(IS_LO_SURR(c)) c = FROM_SURR(str.charCodeAt(i--), c)+ r = MK_CONS(c, r);+ }+ return r;+}++++#if __GLASGOW_HASKELL__ >= 800+function h$jsstringDecInteger(val) {+ TRACE_JSSTRING("decInteger");+ if(IS_INTEGER_S(val)) {+ return '' + INTEGER_S_DATA(val);+ } else if(IS_INTEGER_Jp(val)) {+ return h$ghcjsbn_showBase(INTEGER_J_DATA(val), 10);+ } else {+ return '-' + h$ghcjsbn_showBase(INTEGER_J_DATA(val), 10);+ }+}+#else+function h$jsstringDecInteger(val) {+ TRACE_JSSTRING("decInteger");+ if(IS_INTEGER_S(val)) {+ return '' + INTEGER_S_DATA(val);+ } else {+ return INTEGER_J_DATA(val).toString();+ }+}+#endif++function h$jsstringDecI64(hi,lo) {+ TRACE_JSSTRING("decI64: " + hi + " " + lo);+ var lo0 = (lo < 0) ? lo+4294967296:lo;+ if(hi < 0) {+ if(hi === -1) return ''+(lo0-4294967296);+ lo0 = 4294967296 - lo0;+ var hi0 = -1 - hi;+ var x0 = hi0 * 967296;+ var x1 = (lo0 + x0) % 1000000;+ var x2 = hi0*4294+Math.floor((x0+lo0-x1)/1000000);+ return '-' + x2 + h$jsstringDecIPadded6(x1);+ } else {+ if(hi === 0) return ''+lo0;+ var x0 = hi * 967296;+ var x1 = (lo0 + x0) % 1000000;+ var x2 = hi*4294+Math.floor((x0+lo0-x1)/1000000);+ return '' + x2 + h$jsstringDecIPadded6(x1);+ }+}++function h$jsstringDecW64(hi,lo) {+ TRACE_JSSTRING("decW64: " + hi + " " + lo);+ var lo0 = (lo < 0) ? lo+4294967296 : lo;+ if(hi === 0) return ''+lo0;+ var hi0 = (hi < 0) ? hi+4294967296 : hi;+ var x0 = hi0 * 967296;+ var x1 = (lo0 + x0) % 1000000;+ var x2 = hi0*4294+Math.floor((x0+lo0-x1)/1000000);+ return '' + x2 + h$jsstringDecIPadded6(x1);+}++#if __GLASGOW_HASKELL__ >= 800+function h$jsstringHexInteger(val) {+ TRACE_JSSTRING("hexInteger");+ if(IS_INTEGER_S(val)) {+ return '' + INTEGER_S_DATA(val);+ } else {+ // we assume it's nonnegative. this condition is checked by the Haskell code+ return h$ghcjsbn_showBase(INTEGER_J_DATA(val), 16);+ }+}+#else+function h$jsstringHexInteger(val) {+ TRACE_JSSTRING("hexInteger");+ if(IS_INTEGER_S(val)) {+ return '' + INTEGER_S_DATA(val);+ } else {+ return INTEGER_J_DATA(val).toRadix(16);+ }+}+#endif++function h$jsstringHexI64(hi,lo) {+ var lo0 = lo<0 ? lo+4294967296 : lo;+ if(hi === 0) return lo0.toString(16);+ return ((hi<0)?hi+4294967296:hi).toString(16) + h$jsstringHexIPadded8(lo0);+}++function h$jsstringHexW64(hi,lo) {+ var lo0 = lo<0 ? lo+4294967296 : lo;+ if(hi === 0) return lo0.toString(16);+ return ((hi<0)?hi+4294967296:hi).toString(16) + h$jsstringHexIPadded8(lo0);+}++// n in [0, 1000000000)+function h$jsstringDecIPadded9(n) {+ TRACE_JSSTRING("decIPadded9: " + n);+ if(n === 0) return '000000000';+ var pad = (n>=100000000)?'':+ (n>=10000000)?'0':+ (n>=1000000)?'00':+ (n>=100000)?'000':+ (n>=10000)?'0000':+ (n>=1000)?'00000':+ (n>=100)?'000000':+ (n>=10)?'0000000':+ '00000000';+ return pad+n;+}++// n in [0, 1000000)+function h$jsstringDecIPadded6(n) {+ TRACE_JSSTRING("decIPadded6: " + n);+ if(n === 0) return '000000';+ var pad = (n>=100000)?'':+ (n>=10000)?'0':+ (n>=1000)?'00':+ (n>=100)?'000':+ (n>=10)?'0000':+ '00000';+ return pad+n;+}++// n in [0, 2147483648)+function h$jsstringHexIPadded8(n) {+ TRACE_JSSTRING("hexIPadded8: " + n);+ if(n === 0) return '00000000';+ var pad = (n>=0x10000000)?'':+ (n>=0x1000000)?'0':+ (n>=0x100000)?'00':+ (n>=0x10000)?'000':+ (n>=0x1000)?'0000':+ (n>=0x100)?'00000':+ (n>=0x10)?'000000':+ '0000000';+ return pad+n.toString(16);+}++function h$jsstringZeroes(n) {+ var r;+ switch(n&7) {+ case 0: r = ''; break;+ case 1: r = '0'; break;+ case 2: r = '00'; break;+ case 3: r = '000'; break;+ case 4: r = '0000'; break;+ case 5: r = '00000'; break;+ case 6: r = '000000'; break;+ case 7: r = '0000000';+ }+ for(var i=n>>3;i>0;i--) r = r + '00000000';+ return r;+}++function h$jsstringDoubleToFixed(decs, d) {+ if(decs >= 0) {+ if(Math.abs(d) < 1e21) {+ var r = d.toFixed(Math.min(20,decs));+ if(decs > 20) r = r + h$jsstringZeroes(decs-20);+ return r;+ } else {+ var r = d.toExponential();+ var ei = r.indexOf('e');+ var di = r.indexOf('.');+ var e = parseInt(r.substr(ei+1));+ return r.substring(0,di) + r.substring(di,ei) + h$jsstringZeroes(di-ei+e) ++ ((decs > 0) ? ('.' + h$jsstringZeroes(decs)) : '');+ }+ }+ var r = Math.abs(d).toExponential();+ var ei = r.indexOf('e');+ var e = parseInt(r.substr(ei+1));+ var m = d < 0 ? '-' : '';+ r = r.substr(0,1) + r.substring(2,ei);+ if(e >= 0) {+ return (e > r.length) ? m + r + h$jsstringZeroes(r.length-e-1) + '.0'+ : m + r.substr(0,e+1) + '.' + r.substr(e+1);+ } else {+ return m + '0.' + h$jsstringZeroes(-e-1) + r;+ }+}++function h$jsstringDoubleToExponent(decs, d) {+ var r;+ if(decs ===-1) {+ r = d.toExponential().replace('+','');+ } else {+ r = d.toExponential(Math.max(1, Math.min(20,decs))).replace('+','');+ }+ if(r.indexOf('.') === -1) {+ r = r.replace('e', '.0e');+ }+ if(decs > 20) r = r.replace('e', h$jsstringZeroes(decs-20)+'e');+ return r;+}++function h$jsstringDoubleGeneric(decs, d) {+ var r;+ if(decs === -1) {+ r = d.toString(10).replace('+','');+ } else {+ r = d.toPrecision(Math.max(decs+1,1)).replace('+','');+ }+ if(decs !== 0 && r.indexOf('.') === -1) {+ if(r.indexOf('e') !== -1) {+ r = r.replace('e', '.0e');+ } else {+ r = r + '.0';+ }+ }+ return r;+}++function h$jsstringAppend(x, y) {+ TRACE_JSSTRING("append: '" + x + "' '" + y + "'");+ return x+y;+}++function h$jsstringCompare(x, y) {+ TRACE_JSSTRING("compare: '" + x + "' '" + y + "'");+ return (x<y)?-1:((x>y)?1:0);+}++function h$jsstringUnlines(xs) {+ var r = '';+ while(IS_CONS(xs)) {+ r = r + JSVAL_VAL(CONS_HEAD(xs)) + '\n';+ xs = CONS_TAIL(xs);+ }+ return r;+}++function h$jsstringUnwords(xs) {+ if(IS_NIL(xs)) return '';+ var r = JSVAL_VAL(CONS_HEAD(xs));+ xs = CONS_TAIL(xs);+ while(IS_CONS(xs)) {+ r = r + ' ' + JSVAL_VAL(CONS_HEAD(xs));+ xs = CONS_TAIL(xs);+ }+ return r;+}++function h$jsstringReplace(pat, rep, src) {+ TRACE_JSSTRING("replace: '" + pat + "' '" + rep + "' '" + src + "'");+ var r = src.replace(pat, rep, 'g');+ // the 'g' flag is not supported everywhere, check and fall back if necessary+ if(r.indexOf(pat) !== -1) {+ r = src.split(pat).join(rep);+ }+ return r;+}++function h$jsstringReplicateChar(n, ch) {+ TRACE_JSSTRING("replicateChar: " + n + " " + ch);+ return h$jsstringReplicate(n, h$jsstringSingleton(ch));+}++function h$jsstringIsInteger(str) {+ return /^-?\d+$/.test(str);+}++function h$jsstringIsNatural(str) {+ return /^\d+$/.test(str);+}++function h$jsstringReadInt(str) {+ if(!/^-?\d+/.test(str)) return null;+ var x = parseInt(str, 10);+ var x0 = x|0;+ return (x===x0) ? x0 : null;+}++function h$jsstringLenientReadInt(str) {+ var x = parseInt(str, 10);+ var x0 = x|0;+ return (x===x0) ? x0 : null;+}++function h$jsstringReadWord(str) {+ if(!/^\d+/.test(str)) return null;+ var x = parseInt(str, 10);+ var x0 = x|0;+ if(x0<0) return (x===x0+2147483648) ? x0 : null;+ else return (x===x0) ? x0 : null;+}++function h$jsstringReadDouble(str) {+ return parseFloat(str, 10);+}++function h$jsstringLenientReadDouble(str) {+ return parseFloat(str, 10);+}++function h$jsstringReadInteger(str) {+ TRACE_JSSTRING("readInteger: " + str);+ if(!/^(-)?\d+$/.test(str)) {+ return null;+ } else if(str.length <= 9) {+ return MK_INTEGER_S(parseInt(str, 10));+ } else {+#if __GLASGOW_HASKELL__ >= 800+ return h$ghcjsbn_readInteger(str);+#else+ return MK_INTEGER_J(new BigInteger(str, 10));+#endif+ }+}++function h$jsstringReadInt64(str) {+ if(!/^(-)?\d+$/.test(str)) {+ RETURN_UBX_TUP3(0, 0, 0);+ }+ if(str.charCodeAt(0) === 45) { // '-'+ return h$jsstringReadValue64(str, 1, true);+ } else {+ return h$jsstringReadValue64(str, 0, false);+ }+}++function h$jsstringReadWord64(str) {+ if(!/^\d+$/.test(str)) {+ RETURN_UBX_TUP3(0, 0, 0);+ }+ return h$jsstringReadValue64(str, 0, false);+}++var h$jsstringLongs = null;++function h$jsstringReadValue64(str, start, negate) {+ var l = str.length, i = start;+ while(i < l) {+ if(str.charCodeAt(i) !== 48) break;+ i++;+ }+ if(i >= l) RETURN_UBX_TUP3(1, 0, 0); // only zeroes+ if(h$jsstringLongs === null) {+ h$jsstringLongs = [];+ for(var t=10; t<=1000000000; t*=10) {+ h$jsstringLongs.push(goog.math.Long.fromInt(t));+ }+ }+ var li = l-i;+ if(li < 10 && !negate) {+ RETURN_UBX_TUP3(1, 0, parseInt(str.substr(i), 10));+ }+ var r = goog.math.Long.fromInt(parseInt(str.substr(li,9),10));+ li += 9;+ while(li < l) {+ r = r.multiply(h$jsstringLongs[Math.min(l-li-1,8)])+ .add(goog.math.Long.fromInt(parseInt(str.substr(li,9), 10)));+ li += 9;+ }+ if(negate) {+ r = r.negate();+ }+ RETURN_UBX_TUP3(1, r.getHighBits(), r.getLowBits());+}++function h$jsstringExecRE(i, str, re) {+ re.lastIndex = i;+ var m = re.exec(str);+ if(m === null) return -1;+ var a = [], x, j = 1, r = HS_NIL;+ while(true) {+ x = m[j];+ if(typeof x === 'undefined') break;+ a[j-1] = x;+ j++;+ }+ j-=1;+ while(--j>=0) r = MK_CONS(MK_JSVAL(a[j]), r);+ RETURN_UBX_TUP3(m.index, m[0], r);+}++function h$jsstringReplaceRE(pat, replacement, str) {+ return str.replace(pat, replacement);+}++function h$jsstringSplitRE(limit, re, str) {+ re.lastIndex = i;+ var s = (limit < 0) ? str.split(re) : str.split(re, limit);+ var i = s.length, r = HS_NIL;+ while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r);+ return r;+}
+ jsbits/jsstringRaw.js view
@@ -0,0 +1,21 @@+#include <ghcjs/rts.h>++/*+ * Functions that directly access JavaScript strings, ignoring character+ * widths and surrogate pairs.+ */++function h$jsstringRawChunksOf(k, x) {+ var l = x.length;+ if(l === 0) return HS_NIL;+ if(l <= k) return MK_CONS(MK_JSVAL(x), HS_NIL);+ var r=HS_NIL;+ for(var i=ls-k;i>=0;i-=k) r = MK_CONS(MK_JSVAL(x.substr(i,i+k)),r);+ return r;+}++function h$jsstringRawSplitAt(k, x) {+ if(k === 0) return MK_TUP2(h$jsstringEmpty, MK_JSVAL(x));+ if(k >= x.length) return MK_TUP2(MK_JSVAL(x), h$jsstringEmpty);+ return MK_TUP2(MK_JSVAL(x.substr(0,k)), MK_JSVAL(x.substr(k)));+}
+ jsbits/text.js view
@@ -0,0 +1,53 @@+// conversion between JavaScript string and Data.Text+#include <ghcjs/rts.h>+++/*+ convert a Data.Text buffer with offset/length to a JavaScript string+ */+function h$textToString(arr, off, len) {+ var a = [];+ var end = off+len;+ var k = 0;+ var u1 = arr.u1;+ var s = '';+ for(var i=off;i<end;i++) {+ var cc = u1[i];+ a[k++] = cc;+ if(k === 60000) {+ s += String.fromCharCode.apply(this, a);+ k = 0;+ a = [];+ }+ }+ return s + String.fromCharCode.apply(this, a);+}++/*+ convert a JavaScript string to a Data.Text buffer, second return+ value is length+ */+function h$textFromString(s) {+ var l = s.length;+ var b = h$newByteArray(l * 2);+ var u1 = b.u1;+ for(var i=l-1;i>=0;i--) u1[i] = s.charCodeAt(i);+ RETURN_UBX_TUP2(b, l);+}++function h$lazyTextToString(txt) {+ var s = '';+ while(LAZY_TEXT_IS_CHUNK(txt)) {+ var head = LAZY_TEXT_CHUNK_HEAD(txt);+ s += h$textToString(DATA_TEXT_ARRAY(head), DATA_TEXT_OFFSET(head), DATA_TEXT_LENGTH(head));+ txt = LAZY_TEXT_CHUNK_TAIL(txt);+ }+ return s;+}++function h$safeTextFromString(x) {+ if(typeof x !== 'string') {+ RETURN_UBX_TUP2(null, 0);+ }+ return h$textFromString(x);+}
+ jsbits/utils.js view
@@ -0,0 +1,93 @@+#include <ghcjs/rts.h>++function h$allProps(o) {+ var a = [], i = 0;+ for(var p in o) a[i++] = p;+ return a;+}++function h$listProps(o) {+ var r = HS_NIL;+ for(var p in o) { r = MK_CONS(MK_JSVAL(p), r); }+ return r;+}++function h$listAssocs(o) {+ var r = HS_NIL;+ for(var p in o) { r = MK_CONS(MK_TUP2(MK_JSVAL(p), MK_JSVAL(o[p])), r); }+ return r;+}++function h$isNumber(o) {+ return typeof(o) === 'number';+}++// returns true for null, but not for functions and host objects+function h$isObject(o) {+ return typeof(o) === 'object';+}++function h$isString(o) {+ return typeof(o) === 'string';+}++function h$isSymbol(o) {+ return typeof(o) === 'symbol';+}++function h$isBoolean(o) {+ return typeof(o) === 'boolean';+}++function h$isFunction(o) {+ return typeof(o) === 'function';+}++function h$jsTypeOf(o) {+ var t = typeof(o);+ if(t === 'undefined') return 0;+ if(t === 'object') return 1;+ if(t === 'boolean') return 2;+ if(t === 'number') return 3;+ if(t === 'string') return 4;+ if(t === 'symbol') return 5;+ if(t === 'function') return 6;+ return 7; // other, host object etc+}++/*+ -- 0 - null, 1 - integer,+ -- 2 - float, 3 - bool,+ -- 4 - string, 5 - array+ -- 6 - object+*/+function h$jsonTypeOf(o) {+ if (!(o instanceof Object)) {+ if (o == null) {+ return 0;+ } else if (typeof o == 'number') {+ if (h$isInteger(o)) {+ return 1;+ } else {+ return 2;+ }+ } else if (typeof o == 'boolean') {+ return 3;+ } else {+ return 4;+ }+ } else {+ if (Object.prototype.toString.call(o) == '[object Array]') {+ // it's an array+ return 5;+ } else if (!o) {+ // null + return 0;+ } else {+ // it's an object+ return 6;+ }+ }++}+
+ jsbits/websocket.js view
@@ -0,0 +1,58 @@+#include <ghcjs/rts.h>++function h$createWebSocket(url, protocols) {+ return new WebSocket(url, protocols);+}++/*+ this must be called before the websocket has connected,+ typically synchronously after creating the socket+ */+function h$openWebSocket(ws, mcb, ccb, c) {+ if(ws.readyState !== 0) {+ throw new Error("h$openWebSocket: unexpected readyState, socket must be CONNECTING");+ }+ ws.lastError = null;+ ws.onopen = function() {+ if(mcb) {+ ws.onmessage = mcb;+ }+ if(ccb || mcb) {+ ws.onclose = function(ce) {+ if(ws.onmessage) {+ h$release(ws.onmessage);+ ws.onmessage = null;+ }+ if(ccb) {+ h$release(ccb);+ ccb(ce);+ }+ };+ };+ ws.onerror = function(err) {+ ws.lastError = err;+ if(ws.onmessage) {+ h$release(ws.onmessage);+ ws.onmessage = null;+ }+ ws.close();+ };+ c(null);+ };+ ws.onerror = function(err) {+ if(ccb) h$release(ccb);+ if(mcb) h$release(mcb);+ ws.onmessage = null;+ ws.close();+ c(err);+ };+}++function h$closeWebSocket(status, reason, ws) {+ ws.onerror = null;+ if(ws.onmessage) {+ h$release(ws.onmessage);+ ws.onmessage = null;+ }+ ws.close(status, reason);+}
+ jsbits/xhr.js view
@@ -0,0 +1,16 @@+function h$sendXHR(xhr, d, cont) {+ xhr.addEventListener('error', function () {+ cont(2);+ });+ xhr.addEventListener('abort', function() {+ cont(1);+ });+ xhr.addEventListener('load', function() {+ cont(0);+ });+ if(d) {+ xhr.send(d);+ } else {+ xhr.send();+ }+}
+ test/Tests.hs view
@@ -0,0 +1,15 @@+-- | Provides a simple main function which runs all the tests+--+module Main+ ( main+ ) where++import Test.Framework (defaultMain)++import qualified Tests.Buffer as Buffer+import qualified Tests.Properties as Properties+import qualified Tests.Regressions as Regressions+import qualified Tests.Marshal as Marshal++main :: IO ()+main = defaultMain [Buffer.tests, Properties.tests, Regressions.tests, Marshal.tests]
+ test/Tests/Marshal.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleContexts, OverlappingInstances #-}+module Tests.Marshal (+ tests+) where++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import GHCJS.Marshal.Pure (PFromJSVal(..), PToJSVal(..))+import GHCJS.Marshal (FromJSVal(..), ToJSVal(..))+import Tests.QuickCheckUtils (eq)+import Test.QuickCheck.Monadic (run, monadicIO)+import Test.QuickCheck (once, Arbitrary(..), Property)+import Data.Int (Int32, Int16, Int8)+import Data.Word (Word32, Word16, Word8)+import Data.Text (Text)+import qualified Data.Text as T (unpack, pack)+import Data.JSString (JSString)++newtype TypeName a = TypeName String++pure_to_from_jsval' :: (PToJSVal a, PFromJSVal a, Eq a) => a -> Bool+pure_to_from_jsval' a = pFromJSVal (pToJSVal a) == a++pure_to_from_jsval :: (PToJSVal a, PFromJSVal a, Eq a) => TypeName a -> a -> Bool+pure_to_from_jsval _ = pure_to_from_jsval'++pure_to_from_jsval_maybe :: (PToJSVal a, PFromJSVal a, Eq a) => TypeName a -> Maybe a -> Bool+pure_to_from_jsval_maybe _ = pure_to_from_jsval'++to_from_jsval' :: (ToJSVal a, FromJSVal a, Eq a) => a -> Property+to_from_jsval' a = monadicIO $ do+ b <- run $ toJSVal a >>= fromJSValUnchecked+ return $ b == a++to_from_jsval :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> a -> Property+to_from_jsval _ = to_from_jsval'++to_from_jsval_maybe :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> Maybe a -> Property+to_from_jsval_maybe _ = to_from_jsval'++to_from_jsval_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [a] -> Property+to_from_jsval_list _ = to_from_jsval'++to_from_jsval_list_maybe :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [Maybe a] -> Property+to_from_jsval_list_maybe _ = to_from_jsval'++to_from_jsval_list_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [[a]] -> Property+to_from_jsval_list_list _ = to_from_jsval'++to_from_jsval_maybe_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> Maybe [a] -> Property+to_from_jsval_maybe_list _ = to_from_jsval'++pureMarshalTestGroup :: (PToJSVal a, PFromJSVal a, ToJSVal a, FromJSVal a, Eq a, Show a, Arbitrary a) => TypeName a -> Test+pureMarshalTestGroup t@(TypeName n) =+ testGroup n [+ testProperty "pure_to_from_jsval" (pure_to_from_jsval t),+ testProperty "pure_to_from_jsval_maybe" (pure_to_from_jsval_maybe t),+ testProperty "to_from_jsval" (to_from_jsval t),+ testProperty "to_from_jsval_maybe" (to_from_jsval_maybe t),+ testProperty "to_from_jsval_list" (to_from_jsval_list t),+ testProperty "to_from_jsval_list_maybe" (to_from_jsval_list_maybe t),+ testProperty "to_from_jsval_list_list" (once $ to_from_jsval_list_list t),+ testProperty "to_from_jsval_maybe_list" (to_from_jsval_maybe_list t)+ ]++marshalTestGroup :: (ToJSVal a, FromJSVal a, Eq a, Show a, Arbitrary a) => TypeName a -> Test+marshalTestGroup t@(TypeName n) =+ testGroup n [testProperty "to_from_jsval" (to_from_jsval t)]++instance Arbitrary Text where+ arbitrary = T.pack <$> arbitrary+ shrink = map T.pack . shrink . T.unpack++tests :: Test+tests =+ testGroup "Marshal" [+ pureMarshalTestGroup (TypeName "Bool" :: TypeName Bool ),+ pureMarshalTestGroup (TypeName "Int" :: TypeName Int ),+ pureMarshalTestGroup (TypeName "Int8" :: TypeName Int8 ),+ pureMarshalTestGroup (TypeName "Int16" :: TypeName Int16 ),+ pureMarshalTestGroup (TypeName "Int32" :: TypeName Int32 ),+ pureMarshalTestGroup (TypeName "Word" :: TypeName Word ),+ pureMarshalTestGroup (TypeName "Word8" :: TypeName Word8 ),+ pureMarshalTestGroup (TypeName "Word16" :: TypeName Word16 ),+ pureMarshalTestGroup (TypeName "Word32" :: TypeName Word32 ),+ pureMarshalTestGroup (TypeName "Float" :: TypeName Float ),+ pureMarshalTestGroup (TypeName "Double" :: TypeName Double ),+ pureMarshalTestGroup (TypeName "[Char]" :: TypeName [Char] ),+ pureMarshalTestGroup (TypeName "Text" :: TypeName Text ),+ pureMarshalTestGroup (TypeName "JSString" :: TypeName JSString)+ ]
+ test/Tests/Properties.hs view
@@ -0,0 +1,795 @@+-- | QuickCheck properties for JSString, based on those from the text library.++{-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings,+ ScopedTypeVariables, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties+ (+ tests+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Arrow ((***), second)+import Data.Bits ((.&.))+import Data.Char (chr, isDigit, isHexDigit, isLower, isSpace, isUpper, ord)+-- import Data.Int (Int8, Int16, Int32, Int64)+import Data.Monoid (Monoid(..))+import Data.String (fromString)+-- import Data.Word (Word, Word8, Word16, Word32, Word64)+-- import Numeric (showEFloat, showFFloat, showGFloat, showHex)+import Prelude hiding (replicate)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Monadic+import Test.QuickCheck.Property (Property(..))+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), Assertion)+import Text.Show.Functions ()+import qualified Control.Exception as Exception+import qualified Data.Bits as Bits (shiftL, shiftR)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.List as L+import Data.Word (Word, Word8, Word16, Word32, Word64)++import qualified System.IO as IO++import qualified Tests.SlowFunctions as Slow+import Tests.Properties.Numeric+import Tests.QuickCheckUtils+import Tests.Utils++import qualified Data.JSString as J+import qualified Data.JSString.Int as JI+import qualified Data.JSString.RealFloat as JR+import Data.JSString.Internal.Search (indices)+import qualified Data.JSString.Internal.Fusion as S+import qualified Data.JSString.Internal.Fusion.Common as S++j_pack_unpack = (J.unpack . J.pack) `eq` id+j_pack_unpack' = (J.unpack' . J.pack) `eq` id+j_stream_unstream = (S.unstream . S.stream) `eq` id+j_reverse_stream t = (S.reverse . S.reverseStream) t == t+j_singleton c = [c] == (J.unpack . J.singleton) c+j_singleton' c = [c] == (J.unpack' . J.singleton) c++-- Insufficiently handled by quickcheck+packingAstralPlaneCharacter :: Assertion+packingAstralPlaneCharacter = J.unpack (J.pack "\120590") @=? "\120590"++s_Eq s = (s==) `eq` ((S.streamList s==) . S.streamList)+ where _types = s :: String+sf_Eq p s =+ ((L.filter p s==) . L.filter p) `eq`+ (((S.filter p $ S.streamList s)==) . S.filter p . S.streamList)+j_Eq s = (s==) `eq` ((J.pack s==) . J.pack)+s_Ord s = (compare s) `eq` (compare (S.streamList s) . S.streamList)+ where _types = s :: String+sf_Ord p s =+ ((compare $ L.filter p s) . L.filter p) `eq`+ (compare (S.filter p $ S.streamList s) . S.filter p . S.streamList)+j_Ord s = (compare s) `eq` (compare (J.pack s) . J.pack)+j_Read = id `eq` (J.unpack . read . show)+j_Show = show `eq` (show . J.pack)+j_mappend s = mappend s`eqP` (unpackS . mappend (J.pack s))+j_mconcat = unsquare $+ mconcat `eq` (unpackS . mconcat . L.map J.pack)+j_mempty = mempty == (unpackS (mempty :: J.JSString))+j_IsString = fromString `eqP` (J.unpack . fromString)++s_cons x = (x:) `eqP` (unpackS . S.cons x)+s_cons_s x = (x:) `eqP` (unpackS . S.unstream . S.cons x)+sf_cons p x = ((x:) . L.filter p) `eqP` (unpackS . S.cons x . S.filter p)+j_cons x = (x:) `eqP` (unpackS . J.cons x)+s_snoc x = (++ [x]) `eqP` (unpackS . (flip S.snoc) x)+j_snoc x = (++ [x]) `eqP` (unpackS . (flip J.snoc) x)+s_append s = (s++) `eqP` (unpackS . S.append (S.streamList s))+s_append_s s = (s++) `eqP`+ (unpackS . S.unstream . S.append (S.streamList s))+sf_append p s = (L.filter p s++) `eqP`+ (unpackS . S.append (S.filter p $ S.streamList s))+j_append s = (s++) `eqP` (unpackS . J.append (packS s))++uncons (x:xs) = Just (x,xs)+uncons _ = Nothing++s_uncons = uncons `eqP` (fmap (second unpackS) . S.uncons)+sf_uncons p = (uncons . L.filter p) `eqP`+ (fmap (second unpackS) . S.uncons . S.filter p)+j_uncons = uncons `eqP` (fmap (second unpackS) . J.uncons)+s_head = head `eqP` S.head+sf_head p = (head . L.filter p) `eqP` (S.head . S.filter p)+j_head = head `eqP` J.head+s_last = last `eqP` S.last+sf_last p = (last . L.filter p) `eqP` (S.last . S.filter p)+j_last = last `eqP` J.last+s_tail = tail `eqP` (unpackS . S.tail)+s_tail_s = tail `eqP` (unpackS . S.unstream . S.tail)+sf_tail p = (tail . L.filter p) `eqP` (unpackS . S.tail . S.filter p)+j_tail = tail `eqP` (unpackS . J.tail)+s_init = init `eqP` (unpackS . S.init)+s_init_s = init `eqP` (unpackS . S.unstream . S.init)+sf_init p = (init . L.filter p) `eqP` (unpackS . S.init . S.filter p)+j_init = init `eqP` (unpackS . J.init)+s_null = null `eqP` S.null+sf_null p = (null . L.filter p) `eqP` (S.null . S.filter p)+j_null = null `eqP` J.null+s_length = length `eqP` S.length+sf_length p = (length . L.filter p) `eqP` (S.length . S.filter p)+j_length = length `eqP` J.length+j_compareLength t = (compare (J.length t)) `eq` J.compareLength t++s_map f = map f `eqP` (unpackS . S.map f)+s_map_s f = map f `eqP` (unpackS . S.unstream . S.map f)+sf_map p f = (map f . L.filter p) `eqP` (unpackS . S.map f . S.filter p)+j_map f = map f `eqP` (unpackS . J.map f)+s_intercalate c = unsquare $+ L.intercalate c `eq`+ (unpackS . S.intercalate (packS c) . map packS)+j_intercalate c = unsquare $+ L.intercalate c `eq`+ (unpackS . J.intercalate (packS c) . map packS)+s_intersperse c = L.intersperse c `eqP`+ (unpackS . S.intersperse c)+s_intersperse_s c = L.intersperse c `eqP`+ (unpackS . S.unstream . S.intersperse c)+sf_intersperse p c= (L.intersperse c . L.filter p) `eqP`+ (unpackS . S.intersperse c . S.filter p)+j_intersperse c = unsquare $+ L.intersperse c `eqP` (unpackS . J.intersperse c)+j_transpose = unsquare $+ L.transpose `eq` (map unpackS . J.transpose . map packS)+j_reverse = L.reverse `eqP` (unpackS . J.reverse)+-- s_reverse_short n = L.reverse `eqP` (unpackS . S.reverse . shorten n . S.stream)++j_replace s d = (L.intercalate d . splitOn s) `eqP`+ (unpackS . J.replace (J.pack s) (J.pack d))++splitOn :: (Show a, Eq a) => [a] -> [a] -> [[a]]+splitOn pat src0+ | l == 0 = error "splitOn: empty"+ | otherwise = go src0+ where+ l = length pat+ go src = search 0 src+ where+ search _ [] = [src]+ search !n s@(_:s')+ | pat `L.isPrefixOf` s = take n src : go (drop l s)+ | otherwise = search (n+1) s'++s_toCaseFold_length xs = S.length (S.toCaseFold s) >= length xs+ where s = S.streamList xs+sf_toCaseFold_length p xs =+ (S.length . S.toCaseFold . S.filter p $ s) >= (length . L.filter p $ xs)+ where s = S.streamList xs+j_toCaseFold_length t = J.length (J.toCaseFold t) >= J.length t+j_toLower_length t = J.length (J.toLower t) >= J.length t+j_toLower_lower t = p (J.toLower t) >= p t+ where p = J.length . J.filter isLower+j_toUpper_length t = J.length (J.toUpper t) >= J.length t+j_toUpper_upper t = p (J.toUpper t) >= p t+ where p = J.length . J.filter isUpper++justifyLeft k c xs = xs ++ L.replicate (k - length xs) c+justifyRight m n xs = L.replicate (m - length xs) n ++ xs+center k c xs+ | len >= k = xs+ | otherwise = L.replicate l c ++ xs ++ L.replicate r c+ where len = length xs+ d = k - len+ r = d `div` 2+ l = d - r++s_justifyLeft k c = justifyLeft j c `eqP` (unpackS . S.justifyLeftI j c)+ where j = fromIntegral (k :: Word8)+s_justifyLeft_s k c = justifyLeft j c `eqP`+ (unpackS . S.unstream . S.justifyLeftI j c)+ where j = fromIntegral (k :: Word8)+sf_justifyLeft p k c = (justifyLeft j c . L.filter p) `eqP`+ (unpackS . S.justifyLeftI j c . S.filter p)+ where j = fromIntegral (k :: Word8)+j_justifyLeft k c = justifyLeft j c `eqP` (unpackS . J.justifyLeft j c)+ where j = fromIntegral (k :: Word8)+j_justifyRight k c = justifyRight j c `eqP` (unpackS . J.justifyRight j c)+ where j = fromIntegral (k :: Word8)++j_center k c = center j c `eqP` (unpackS . J.center j c)+ where j = fromIntegral (k :: Word8)++sf_foldl p f z = (L.foldl f z . L.filter p) `eqP` (S.foldl f z . S.filter p)+ where _types = f :: Char -> Char -> Char+j_foldl f z = L.foldl f z `eqP` (J.foldl f z)+ where _types = f :: Char -> Char -> Char+sf_foldl' p f z = (L.foldl' f z . L.filter p) `eqP`+ (S.foldl' f z . S.filter p)+ where _types = f :: Char -> Char -> Char+j_foldl' f z = L.foldl' f z `eqP` J.foldl' f z+ where _types = f :: Char -> Char -> Char+sf_foldl1 p f = (L.foldl1 f . L.filter p) `eqP` (S.foldl1 f . S.filter p)+j_foldl1 f = L.foldl1 f `eqP` J.foldl1 f+sf_foldl1' p f = (L.foldl1' f . L.filter p) `eqP` (S.foldl1' f . S.filter p)+j_foldl1' f = L.foldl1' f `eqP` J.foldl1' f+sf_foldr p f z = (L.foldr f z . L.filter p) `eqP` (S.foldr f z . S.filter p)+ where _types = f :: Char -> Char -> Char+j_foldr f z = L.foldr f z `eqP` J.foldr f z+ where _types = f :: Char -> Char -> Char+sf_foldr1 p f = unsquare $+ (L.foldr1 f . L.filter p) `eqP` (S.foldr1 f . S.filter p)+j_foldr1 f = L.foldr1 f `eqP` J.foldr1 f++s_concat_s = unsquare $+ L.concat `eq` (unpackS . S.unstream . S.concat . map packS)+sf_concat p = unsquare $+ (L.concat . map (L.filter p)) `eq`+ (unpackS . S.concat . map (S.filter p . packS))+j_concat = unsquare $+ L.concat `eq` (unpackS . J.concat . map packS)+sf_concatMap p f = unsquare $ (L.concatMap f . L.filter p) `eqP`+ (unpackS . S.concatMap (packS . f) . S.filter p)+j_concatMap f = unsquare $+ L.concatMap f `eqP` (unpackS . J.concatMap (packS . f))+sf_any q p = (L.any p . L.filter q) `eqP` (S.any p . S.filter q)+j_any p = L.any p `eqP` J.any p+sf_all q p = (L.all p . L.filter q) `eqP` (S.all p . S.filter q)+j_all p = L.all p `eqP` J.all p+sf_maximum p = (L.maximum . L.filter p) `eqP` (S.maximum . S.filter p)+j_maximum = L.maximum `eqP` J.maximum+sf_minimum p = (L.minimum . L.filter p) `eqP` (S.minimum . S.filter p)+j_minimum = L.minimum `eqP` J.minimum++sf_scanl p f z = (L.scanl f z . L.filter p) `eqP`+ (unpackS . S.scanl f z . S.filter p)+j_scanl f z = L.scanl f z `eqP` (unpackS . J.scanl f z)+j_scanl1 f = L.scanl1 f `eqP` (unpackS . J.scanl1 f)+j_scanr f z = L.scanr f z `eqP` (unpackS . J.scanr f z)+j_scanr1 f = L.scanr1 f `eqP` (unpackS . J.scanr1 f)++j_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . J.mapAccumL f z)+ where _types = f :: Int -> Char -> (Int,Char)+j_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . J.mapAccumR f z)+ where _types = f :: Int -> Char -> (Int,Char)++replicate n l = concat (L.replicate n l)++s_replicate n = replicate m `eq`+ (unpackS . S.replicateI (fromIntegral m) . packS)+ where m = fromIntegral (n :: Word8)+j_replicate n = replicate m `eq` (unpackS . J.replicate m . packS)+ where m = fromIntegral (n :: Word8)++unf :: Int -> Char -> Maybe (Char, Char)+unf n c | fromEnum c * 100 > n = Nothing+ | otherwise = Just (c, succ c)++j_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . J.unfoldr (unf m))+ where m = fromIntegral (n :: Word16)+j_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`+ (unpackS . J.unfoldrN i (unf j))+ where i = fromIntegral (n :: Word16)+ j = fromIntegral (m :: Word16)++unpack2 :: (Stringy s) => (s,s) -> (String,String)+unpack2 = unpackS *** unpackS++s_take n = L.take n `eqP` (unpackS . S.take n)+s_take_s m = L.take n `eqP` (unpackS . S.unstream . S.take n)+ where n = small m+sf_take p n = (L.take n . L.filter p) `eqP`+ (unpackS . S.take n . S.filter p)+j_take n = L.take n `eqP` (unpackS . J.take n)+j_takeEnd n = (L.reverse . L.take n . L.reverse) `eqP`+ (unpackS . J.takeEnd n)+s_drop n = L.drop n `eqP` (unpackS . S.drop n)+s_drop_s m = L.drop n `eqP` (unpackS . S.unstream . S.drop n)+ where n = small m+sf_drop p n = (L.drop n . L.filter p) `eqP`+ (unpackS . S.drop n . S.filter p)+j_drop n = L.drop n `eqP` (unpackS . J.drop n)+j_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`+ (unpackS . J.dropEnd n)+s_take_drop m = (L.take n . L.drop n) `eqP` (unpackS . S.take n . S.drop n)+ where n = small m+s_take_drop_s m = (L.take n . L.drop n) `eqP`+ (unpackS . S.unstream . S.take n . S.drop n)+ where n = small m+s_takeWhile p = L.takeWhile p `eqP` (unpackS . S.takeWhile p)+s_takeWhile_s p = L.takeWhile p `eqP` (unpackS . S.unstream . S.takeWhile p)+sf_takeWhile q p = (L.takeWhile p . L.filter q) `eqP`+ (unpackS . S.takeWhile p . S.filter q)+j_takeWhile p = L.takeWhile p `eqP` (unpackS . J.takeWhile p)+s_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)+s_dropWhile_s p = L.dropWhile p `eqP` (unpackS . S.unstream . S.dropWhile p)+sf_dropWhile q p = (L.dropWhile p . L.filter q) `eqP`+ (unpackS . S.dropWhile p . S.filter q)+j_dropWhile p = L.dropWhile p `eqP` (unpackS . J.dropWhile p)+j_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`+ (unpackS . J.dropWhileEnd p)+j_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)+ `eqP` (unpackS . J.dropAround p)+j_stripStart = J.dropWhile isSpace `eq` J.stripStart+j_stripEnd = J.dropWhileEnd isSpace `eq` J.stripEnd+j_strip = J.dropAround isSpace `eq` J.strip+j_splitAt n = L.splitAt n `eqP` (unpack2 . J.splitAt n)+j_span p = L.span p `eqP` (unpack2 . J.span p)++j_breakOn_id s = squid `eq` (uncurry J.append . J.breakOn s)+ where squid t | J.null s = error "empty"+ | otherwise = t+j_breakOn_start (NotEmpty s) t =+ let (k,m) = J.breakOn s t+ in k `J.isPrefixOf` t && (J.null m || s `J.isPrefixOf` m)+j_breakOnEnd_end (NotEmpty s) t =+ let (m,k) = J.breakOnEnd s t+ in k `J.isSuffixOf` t && (J.null m || s `J.isSuffixOf` m)+j_break p = L.break p `eqP` (unpack2 . J.break p)+j_group = L.group `eqP` (map unpackS . J.group)+j_groupBy p = L.groupBy p `eqP` (map unpackS . J.groupBy p)+j_inits = L.inits `eqP` (map unpackS . J.inits)+j_tails = L.tails `eqP` (map unpackS . J.tails)+j_findAppendId = unsquare $ \(NotEmpty s) ts ->+ let t = J.intercalate s ts+ in all (==t) $ map (uncurry J.append) (J.breakOnAll s t)++j_findContains = unsquare $ \(NotEmpty s) ->+ all (J.isPrefixOf s . snd) . J.breakOnAll s . J.intercalate s+j_findContains' = unsquare $ \(NotEmpty s) ->+ all (J.isPrefixOf s . snd) . J.breakOnAll' s . J.intercalate s++j_findCount s = (L.length . J.breakOnAll s) `eq` J.count s+j_findCount' s = (L.length . J.breakOnAll' s) `eq` J.count s++j_splitOn_split s = unsquare $+ (J.splitOn s `eq` Slow.splitOn s) . J.intercalate s+j_splitOn'_split s = unsquare $+ (J.splitOn' s `eq` Slow.splitOn s) . J.intercalate s+j_splitOn_i (NotEmpty t) = id `eq` (J.intercalate t . J.splitOn t)+j_splitOn'_i (NotEmpty t) = id `eq` (J.intercalate t . J.splitOn' t)++j_split p = split p `eqP` (map unpackS . J.split p)+j_split_count c = (L.length . J.split (==c)) `eq`+ ((1+) . J.count (J.singleton c))+j_split_splitOn c = J.split (==c) `eq` J.splitOn (J.singleton c)+j_split_splitOn' c = J.split (==c) `eq` J.splitOn' (J.singleton c)++split :: (a -> Bool) -> [a] -> [[a]]+split _ [] = [[]]+split p xs = loop xs+ where loop s | null s' = [l]+ | otherwise = l : loop (tail s')+ where (l, s') = break p s++j_chunksOf_same_lengths k = all ((==k) . J.length) . ini . J.chunksOf k+ where ini [] = []+ ini xs = init xs+j_chunksOf_same_lengths' k = all ((==k) . J.length) . ini . J.chunksOf' k+ where ini [] = []+ ini xs = init xs++j_chunksOf_length k t = len == J.length t || (k <= 0 && len == 0)+ where len = L.sum . L.map J.length $ J.chunksOf k t+j_chunksOf_length' k t = len == J.length t || (k <= 0 && len == 0)+ where len = L.sum . L.map J.length $ J.chunksOf' k t++j_lines = L.lines `eqP` (map unpackS . J.lines)+j_lines' = L.lines `eqP` (map unpackS . J.lines')++j_words = L.words `eqP` (map unpackS . J.words)+j_words' = L.words `eqP` (map unpackS . J.words')++j_unlines = unsquare $+ L.unlines `eq` (unpackS . J.unlines . map packS)+j_unwords = unsquare $+ L.unwords `eq` (unpackS . J.unwords . map packS)++s_isPrefixOf s = L.isPrefixOf s `eqP`+ (S.isPrefixOf (S.stream $ packS s) . S.stream)+sf_isPrefixOf p s = (L.isPrefixOf s . L.filter p) `eqP`+ (S.isPrefixOf (S.stream $ packS s) . S.filter p . S.stream)+j_isPrefixOf s = L.isPrefixOf s`eqP` J.isPrefixOf (packS s)+j_isSuffixOf s = L.isSuffixOf s`eqP` J.isSuffixOf (packS s)+j_isInfixOf s = L.isInfixOf s `eqP` J.isInfixOf (packS s)++j_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` J.stripPrefix (packS s)++stripSuffix p t = reverse `fmap` L.stripPrefix (reverse p) (reverse t)++j_stripSuffix s = (fmap packS . stripSuffix s) `eqP` J.stripSuffix (packS s)++commonPrefixes a0@(_:_) b0@(_:_) = Just (go a0 b0 [])+ where go (a:as) (b:bs) ps+ | a == b = go as bs (a:ps)+ go as bs ps = (reverse ps,as,bs)+commonPrefixes _ _ = Nothing++j_commonPrefixes a b (NonEmpty p)+ = commonPrefixes pa pb ==+ repack `fmap` J.commonPrefixes (packS pa) (packS pb)+ where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)+ pa = p ++ a+ pb = p ++ b++sf_elem p c = (L.elem c . L.filter p) `eqP` (S.elem c . S.filter p)+sf_filter q p = (L.filter p . L.filter q) `eqP`+ (unpackS . S.filter p . S.filter q)+j_filter p = L.filter p `eqP` (unpackS . J.filter p)+sf_findBy q p = (L.find p . L.filter q) `eqP` (S.findBy p . S.filter q)+j_find p = L.find p `eqP` J.find p+j_partition p = L.partition p `eqP` (unpack2 . J.partition p)++sf_index p s = forAll (choose (-l,l*2))+ ((L.filter p s L.!!) `eq` S.index (S.filter p $ packS s))+ where l = L.length s+j_index s = forAll (choose (-l,l*2)) ((s L.!!) `eq` J.index (packS s))+ where l = L.length s++j_findIndex p = L.findIndex p `eqP` J.findIndex p+j_count (NotEmpty t) = (subtract 1 . L.length . J.splitOn t) `eq` J.count t+j_zip s = L.zip s `eqP` J.zip (packS s)+sf_zipWith p c s = (L.zipWith c (L.filter p s) . L.filter p) `eqP`+ (unpackS . S.zipWith c (S.filter p $ packS s) . S.filter p)+j_zipWith c s = L.zipWith c s `eqP` (unpackS . J.zipWith c (packS s))++j_indices (NotEmpty s) = Slow.indices s `eq` indices s+j_indices_occurs = unsquare $ \(NotEmpty t) ts ->+ let s = J.intercalate t ts+ in Slow.indices t s == indices t s++-- Reading.+{-+j_decimal (n::Int) s =+ J.signed J.decimal (J.pack (show n) `J.append` t) == Right (n,t)+ where t = J.dropWhile isDigit s+j_hexadecimal m s ox =+ J.hexadecimal (J.concat [p, J.pack (showHex n ""), t]) == Right (n,t)+ where t = J.dropWhile isHexDigit s+ p = if ox then "0x" else ""+ n = getPositive m :: Int++isFloaty c = c `elem` "+-.0123456789eE"++j_read_rational p tol (n::Double) s =+ case p (J.pack (show n) `J.append` t) of+ Left _err -> False+ Right (n',t') -> t == t' && abs (n-n') <= tol+ where t = J.dropWhile isFloaty s++j_double = j_read_rational J.double 1e-13+j_rational = j_read_rational J.rational 1e-16+-}+-- Input and output.+{-+t_put_get = write_read T.unlines T.filter put get+ where put h = withRedirect h IO.stdout . T.putStr+ get h = withRedirect h IO.stdin T.getContents+tl_put_get = write_read TL.unlines TL.filter put get+ where put h = withRedirect h IO.stdout . TL.putStr+ get h = withRedirect h IO.stdin TL.getContents+t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents+tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents++t_write_read_line e m b t = write_read head T.filter T.hPutStrLn+ T.hGetLine e m b [t]+tl_write_read_line e m b t = write_read head TL.filter TL.hPutStrLn+ TL.hGetLine e m b [t]+-}+-- Low-level.+{-+j_dropWord16 m t = dropWord16 m t `J.isSuffixOf` t+j_takeWord16 m t = takeWord16 m t `J.isPrefixOf` t+j_take_drop_16 m t = J.append (takeWord16 n t) (dropWord16 n t) == t+ where n = small m+j_use_from t = monadicIO $ assert . (==t) =<< run (useAsPtr t fromPtr)+-}+-- Regression tests.+s_filter_eq s = S.filter p t == S.streamList (filter p s)+ where p = (/= S.last t)+ t = S.streamList s++tests :: Test+tests =+ testGroup "Properties" [+ testGroup "creation/elimination" [+ testProperty "j_pack_unpack" j_pack_unpack,+ testProperty "j_pack_unpack'" j_pack_unpack',+ testCase "packing astral plane character" packingAstralPlaneCharacter,+ testProperty "j_stream_unstream" j_stream_unstream,+ testProperty "j_reverse_stream" j_reverse_stream,+ testProperty "j_singleton" j_singleton,+ testProperty "j_singleton'" j_singleton'+ ],++ testGroup "instances" [+ testProperty "s_Eq" s_Eq,+ testProperty "sf_Eq" sf_Eq,+ testProperty "j_Eq" j_Eq,+ testProperty "s_Ord" s_Ord,+ testProperty "sf_Ord" sf_Ord,+ testProperty "j_Ord" j_Ord,+ testProperty "j_Read" j_Read,+ testProperty "j_Show" j_Show,+ testProperty "j_mappend" j_mappend,+ testProperty "j_mconcat" j_mconcat,+ testProperty "j_mempty" j_mempty,+ testProperty "j_IsString" j_IsString+ ],++ testGroup "basics" [+ testProperty "s_cons" s_cons,+ testProperty "s_cons_s" s_cons_s,+ testProperty "sf_cons" sf_cons,+ testProperty "j_cons" j_cons,+ testProperty "s_snoc" s_snoc,+ testProperty "j_snoc" j_snoc,+ testProperty "s_append" s_append,+ testProperty "s_append_s" s_append_s,+ testProperty "sf_append" sf_append,+ testProperty "j_append" j_append,+ testProperty "s_uncons" s_uncons,+ testProperty "sf_uncons" sf_uncons,+ testProperty "j_uncons" j_uncons,+ testProperty "s_head" s_head,+ testProperty "sf_head" sf_head,+ testProperty "j_head" j_head,+ testProperty "s_last" s_last,+ testProperty "sf_last" sf_last,+ testProperty "j_last" j_last,+ testProperty "s_tail" s_tail,+ testProperty "s_tail_s" s_tail_s,+ testProperty "sf_tail" sf_tail,+ testProperty "j_tail" j_tail,+ testProperty "s_init" s_init,+ testProperty "s_init_s" s_init_s,+ testProperty "sf_init" sf_init,+ testProperty "j_init" j_init,+ testProperty "s_null" s_null,+ testProperty "sf_null" sf_null,+ testProperty "j_null" j_null,+ testProperty "s_length" s_length,+ testProperty "sf_length" sf_length,+-- testProperty "sl_length" sl_length,+ testProperty "j_length" j_length,+ testProperty "j_compareLength" j_compareLength+ ],++ testGroup "transformations" [+ testProperty "s_map" s_map,+ testProperty "s_map_s" s_map_s,+ testProperty "sf_map" sf_map,+ testProperty "j_map" j_map,+ testProperty "s_intercalate" s_intercalate,+ testProperty "j_intercalate" j_intercalate,+ testProperty "s_intersperse" s_intersperse,+ testProperty "s_intersperse_s" s_intersperse_s,+ testProperty "sf_intersperse" sf_intersperse,+ testProperty "j_intersperse" j_intersperse,+ testProperty "j_transpose" j_transpose,+ testProperty "j_reverse" j_reverse,+-- testProperty "s_reverse_short" s_reverse_short,+ testProperty "j_replace" j_replace,++ testGroup "case conversion" [+ testProperty "s_toCaseFold_length" s_toCaseFold_length,+ testProperty "sf_toCaseFold_length" sf_toCaseFold_length,+ testProperty "j_toCaseFold_length" j_toCaseFold_length,+ testProperty "j_toLower_length" j_toLower_length,+ testProperty "j_toLower_lower" j_toLower_lower,+ testProperty "j_toUpper_length" j_toUpper_length,+ testProperty "j_toUpper_upper" j_toUpper_upper+ ],++ testGroup "justification" [+ testProperty "s_justifyLeft" s_justifyLeft,+ testProperty "s_justifyLeft_s" s_justifyLeft_s,+ testProperty "sf_justifyLeft" sf_justifyLeft,+ testProperty "j_justifyLeft" j_justifyLeft,+ testProperty "j_justifyRight" j_justifyRight,+ testProperty "j_center" j_center+ ]+ ],++ testGroup "folds" [+ testProperty "sf_foldl" sf_foldl,+ testProperty "j_foldl" j_foldl,+ testProperty "sf_foldl'" sf_foldl',+ testProperty "j_foldl'" j_foldl',+ testProperty "sf_foldl1" sf_foldl1,+ testProperty "j_foldl1" j_foldl1,+ testProperty "j_foldl1'" j_foldl1',+ testProperty "sf_foldl1'" sf_foldl1',+ testProperty "sf_foldr" sf_foldr,+ testProperty "j_foldr" j_foldr,+ testProperty "sf_foldr1" sf_foldr1,+ testProperty "j_foldr1" j_foldr1,++ testGroup "special" [+ testProperty "s_concat_s" s_concat_s,+ testProperty "sf_concat" sf_concat,+ testProperty "j_concat" j_concat,+ testProperty "sf_concatMap" sf_concatMap,+ testProperty "j_concatMap" j_concatMap,+ testProperty "sf_any" sf_any,+ testProperty "j_any" j_any,+ testProperty "sf_all" sf_all,+ testProperty "j_all" j_all,+ testProperty "sf_maximum" sf_maximum,+ testProperty "j_maximum" j_maximum,+ testProperty "sf_minimum" sf_minimum,+ testProperty "j_minimum" j_minimum+ ]+ ],++ testGroup "construction" [+ testGroup "scans" [+ testProperty "sf_scanl" sf_scanl,+ testProperty "j_scanl" j_scanl,+ testProperty "j_scanl1" j_scanl1,+ testProperty "j_scanr" j_scanr,+ testProperty "j_scanr1" j_scanr1+ ],++ testGroup "mapAccum" [+ testProperty "j_mapAccumL" j_mapAccumL,+ testProperty "j_mapAccumR" j_mapAccumR+ ],++ testGroup "unfolds" [+ testProperty "s_replicate" s_replicate,+ testProperty "j_replicate" j_replicate,+ testProperty "j_unfoldr" j_unfoldr,+ testProperty "j_unfoldrN" j_unfoldrN+ ]+ ],++ testGroup "substrings" [+ testGroup "breaking" [+ testProperty "s_take" s_take,+ testProperty "s_take_s" s_take_s,+ testProperty "sf_take" sf_take,+ testProperty "j_take" j_take,+ testProperty "j_takeEnd" j_takeEnd,+ testProperty "s_drop" s_drop,+ testProperty "s_drop_s" s_drop_s,+ testProperty "sf_drop" sf_drop,+ testProperty "j_drop" j_drop,+ testProperty "j_dropEnd" j_dropEnd,+ testProperty "s_take_drop" s_take_drop,+ testProperty "s_take_drop_s" s_take_drop_s,+ testProperty "s_takeWhile" s_takeWhile,+ testProperty "s_takeWhile_s" s_takeWhile_s,+ testProperty "sf_takeWhile" sf_takeWhile,+ testProperty "j_takeWhile" j_takeWhile,+ testProperty "sf_dropWhile" sf_dropWhile,+ testProperty "s_dropWhile" s_dropWhile,+ testProperty "s_dropWhile_s" s_dropWhile_s,+ testProperty "j_dropWhile" j_dropWhile,+ testProperty "j_dropWhileEnd" j_dropWhileEnd,+ testProperty "j_dropAround" j_dropAround,+ testProperty "j_stripStart" j_stripStart,+ testProperty "j_stripEnd" j_stripEnd,+ testProperty "j_strip" j_strip,+ testProperty "j_splitAt" j_splitAt,+ testProperty "j_span" j_span,+ testProperty "j_breakOn_id" j_breakOn_id,+ testProperty "j_breakOn_start" j_breakOn_start,+ testProperty "j_breakOnEnd_end" j_breakOnEnd_end,+ testProperty "j_break" j_break,+ testProperty "j_group" j_group,+ testProperty "j_groupBy" j_groupBy,+ testProperty "j_inits" j_inits,+ testProperty "j_tails" j_tails+ ],++ testGroup "breaking many" [+ testProperty "j_findAppendId" j_findAppendId,+ testProperty "j_findContains" j_findContains,+ testProperty "j_findContains'" j_findContains',+-- testProperty "sl_filterCount" sl_filterCount,+ testProperty "j_findCount" j_findCount,+ testProperty "j_findCount'" j_findCount',+ testProperty "j_splitOn_split" j_splitOn_split,+ testProperty "j_splitOn'_split" j_splitOn'_split,+ testProperty "j_splitOn_i" j_splitOn_i,+ testProperty "j_splitOn'_i" j_splitOn'_i,+ testProperty "j_split" j_split,+ testProperty "j_split_count" j_split_count,+ testProperty "j_split_splitOn" j_split_splitOn,+ testProperty "j_split_splitOn'" j_split_splitOn',+ testProperty "j_chunksOf_same_lengths" j_chunksOf_same_lengths,+ testProperty "j_chunksOf_same_lengths'" j_chunksOf_same_lengths',+ testProperty "j_chunksOf_length" j_chunksOf_length,+ testProperty "j_chunksOf_length'" j_chunksOf_length'+ ],++ testGroup "lines and words" [+ testProperty "j_lines" j_lines,+ testProperty "j_lines'" j_lines',+ testProperty "j_words" j_words,+ testProperty "j_words'" j_words',+ testProperty "j_unlines" j_unlines,+ testProperty "j_unwords" j_unwords+ ]+ ],++ testGroup "predicates" [+ testProperty "s_isPrefixOf" s_isPrefixOf,+ testProperty "sf_isPrefixOf" sf_isPrefixOf,+ testProperty "j_isPrefixOf" j_isPrefixOf,+ testProperty "j_isSuffixOf" j_isSuffixOf,+ testProperty "j_isInfixOf" j_isInfixOf,++ testGroup "view" [+ testProperty "j_stripPrefix" j_stripPrefix,+ testProperty "j_stripSuffix" j_stripSuffix,+ testProperty "j_commonPrefixes" j_commonPrefixes+ ]+ ],++ testGroup "searching" [+ testProperty "sf_elem" sf_elem,+ testProperty "sf_filter" sf_filter,+ testProperty "j_filter" j_filter,+ testProperty "sf_findBy" sf_findBy,+ testProperty "j_find" j_find,+ testProperty "j_partition" j_partition+ ],++ testGroup "indexing" [+ testProperty "sf_index" sf_index,+ testProperty "j_index" j_index,+ testProperty "j_findIndex" j_findIndex,+ testProperty "j_count" j_count,+ testProperty "j_indices" j_indices,+ testProperty "j_indices_occurs" j_indices_occurs+ ],++ testGroup "zips" [+ testProperty "j_zip" j_zip,+ testProperty "sf_zipWith" sf_zipWith,+ testProperty "j_zipWith" j_zipWith+ ],++ testGroup "numeric conversion" [+ testGroup "integral" [+ testProperty "j_decimal_integer" j_decimal_integer,+ testProperty "j_decimal_int" j_decimal_int,+ testProperty "j_decimal_int8" j_decimal_int8,+ testProperty "j_decimal_int16" j_decimal_int16,+ testProperty "j_decimal_int32" j_decimal_int32,+ testProperty "j_decimal_int64" j_decimal_int64,+ testProperty "j_decimal_word" j_decimal_word,+ testProperty "j_decimal_word8" j_decimal_word8,+ testProperty "j_decimal_word16" j_decimal_word16,+ testProperty "j_decimal_word32" j_decimal_word32,+ testProperty "j_decimal_word64" j_decimal_word64,++ testProperty "j_decimal_integer_big" j_decimal_integer_big,+ testProperty "j_decimal_int_big" j_decimal_int_big,+ testProperty "j_decimal_int64_big" j_decimal_int64_big,+ testProperty "j_decimal_word_big" j_decimal_word_big,+ testProperty "j_decimal_word64_big" j_decimal_word64_big,++ testProperty "j_hexadecimal_integer" j_hexadecimal_integer,+ testProperty "j_hexadecimal_int" j_hexadecimal_int,+ testProperty "j_hexadecimal_int8" j_hexadecimal_int8,+ testProperty "j_hexadecimal_int16" j_hexadecimal_int16,+ testProperty "j_hexadecimal_int32" j_hexadecimal_int32,+ testProperty "j_hexadecimal_int64" j_hexadecimal_int64,+ testProperty "j_hexadecimal_word" j_hexadecimal_word,+ testProperty "j_hexadecimal_word8" j_hexadecimal_word8,+ testProperty "j_hexadecimal_word16" j_hexadecimal_word16,+ testProperty "j_hexadecimal_word32" j_hexadecimal_word32,+ testProperty "j_hexadecimal_word64" j_hexadecimal_word64+ ],+ testGroup "realfloat" [+ -- disabled due to rounding differences+ -- testProperty "j_realfloat_double" j_realfloat_double,+ -- testProperty "j_formatRealFloat_double" j_formatRealFloat_double+ ]+ ],++ testGroup "regressions" [+ testProperty "s_filter_eq" s_filter_eq+ ]+ ]
+ test/Tests/Properties/Numeric.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -O2 -fno-warn-missing-signatures #-}+module Tests.Properties.Numeric where++import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import Numeric (showEFloat, showFFloat, showGFloat, showHex)++import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Monadic++-- import GHC.Int+import Tests.QuickCheckUtils+import Tests.Utils++import qualified Data.JSString as J+import qualified Data.JSString.Int as JI+import qualified Data.JSString.RealFloat as JR++j_decimal :: (Integral a, Show a) => a -> Bool+j_decimal = show `eq` (J.unpack . JI.decimal)++j_decimal_integer (a::Integer) = j_decimal a+j_decimal_integer_big (Big a) = j_decimal a+j_decimal_int (a::Int) = j_decimal a+j_decimal_int8 (a::Int8) = j_decimal a+j_decimal_int16 (a::Int16) = j_decimal a+j_decimal_int32 (a::Int32) = j_decimal a+j_decimal_int64 (a::Int64) = j_decimal a+j_decimal_word (a::Word) = j_decimal a+j_decimal_word8 (a::Word8) = j_decimal a+j_decimal_word16 (a::Word16) = j_decimal a+j_decimal_word32 (a::Word32) = j_decimal a+j_decimal_word64 (a::Word64) = j_decimal a++j_decimal_int_big (BigBounded (a::Int)) = j_decimal a+j_decimal_int64_big (BigBounded (a::Int64)) = j_decimal a+j_decimal_word_big (BigBounded (a::Word)) = j_decimal a+j_decimal_word64_big (BigBounded (a::Word64)) = j_decimal a++j_hex :: (Integral a, Show a) => a -> Bool+j_hex = flip showHex "" `eq` (J.unpack . JI.hexadecimal)++j_hexadecimal_integer (a::Integer) = j_hex a+j_hexadecimal_int (a::Int) = j_hex a+j_hexadecimal_int8 (a::Int8) = j_hex a+j_hexadecimal_int16 (a::Int16) = j_hex a+j_hexadecimal_int32 (a::Int32) = j_hex a+j_hexadecimal_int64 (a::Int64) = j_hex a+j_hexadecimal_word (a::Word) = j_hex a+j_hexadecimal_word8 (a::Word8) = j_hex a+j_hexadecimal_word16 (a::Word16) = j_hex a+j_hexadecimal_word32 (a::Word32) = j_hex a+j_hexadecimal_word64 (a::Word64) = j_hex a++j_realfloat :: (RealFloat a, Show a) => a -> Bool+j_realfloat = (J.unpack . JR.realFloat) `eq` show++j_realfloat_float (a::Float) = j_realfloat a+j_realfloat_double (a::Double) = j_realfloat a+++showFloat :: (RealFloat a) => JR.FPFormat -> Maybe Int -> a -> ShowS+showFloat JR.Exponent = showEFloat+showFloat JR.Fixed = showFFloat+showFloat JR.Generic = showGFloat++j_formatRealFloat :: (RealFloat a, Show a) =>+ a -> JR.FPFormat -> Precision a -> Property+j_formatRealFloat a fmt prec =+ J.unpack (JR.formatRealFloat fmt p a) === showFloat fmt p a ""+ where p = precision a prec+{-# INLINE j_formatRealFloat #-}++j_formatRealFloat_float (a::Float) fmt prec = -- j_formatRealFloat a+ J.unpack (JR.formatFloat fmt p a) === showFloat fmt p a ""+ where p = precision a prec+j_formatRealFloat_double (a::Double) fmt prec = -- j_formatRealFloat a+ J.unpack (JR.formatDouble fmt p a) === showFloat fmt p a ""+ where p = precision a prec
+ test/Tests/QuickCheckUtils.hs view
@@ -0,0 +1,328 @@+-- | This module provides quickcheck utilities, e.g. arbitrary and show+-- instances, and comparison functions, so we can focus on the actual properties+-- in the 'Tests.Properties' module.+--+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Tests.QuickCheckUtils+ (+ genUnicode+ , unsquare+ , smallArbitrary++ , BigBounded(..)+ , BigInt(..)+ , NotEmpty(..)++ , Small(..)+ , small++ , Precision(..)+ , precision++ , integralRandomR++-- , DecodeErr(..)+-- , genDecodeErr++ , Stringy(..)+ , eq+ , eqP++ , Encoding(..)++ , write_read+ ) where++import Control.Applicative ((<$>))+import Control.Arrow (first, (***))+import Control.DeepSeq (NFData (..), deepseq)+import Control.Exception (bracket)+import Data.String (IsString, fromString)+-- import Data.Text.Foreign (I16)+-- import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))+import Data.JSString.RealFloat (FPFormat(..))+import Data.Word (Word8, Word16)+import Debug.Trace (trace)+import System.Random (Random(..), RandomGen)+import Test.QuickCheck hiding (Fixed(..), Small (..), (.&.))+import Test.QuickCheck.Monadic (assert, monadicIO, run)+import Test.QuickCheck.Unicode (string)+import Tests.Utils++import qualified Data.JSString as J+import qualified Data.JSString.Internal.Fusion as JF+import qualified Data.JSString.Internal.Fusion.Common as JF++import qualified Data.ByteString as B+import qualified System.IO as IO++genUnicode :: IsString a => Gen a+genUnicode = fromString <$> string++-- | A type representing a number of UTF-16 code units.+newtype I16 = I16 Int+ deriving (Bounded, Enum, Eq, Integral, Num, Ord, Read, Real, Show)+++instance Random I16 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Arbitrary I16 where+ arbitrary = arbitrarySizedIntegral+ shrink = shrinkIntegral++instance Arbitrary B.ByteString where+ arbitrary = B.pack `fmap` arbitrary+ shrink = map B.pack . shrink . B.unpack++-- For tests that have O(n^2) running times or input sizes, resize+-- their inputs to the square root of the originals.+unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property+unsquare = forAll smallArbitrary++smallArbitrary :: (Arbitrary a, Show a) => Gen a+smallArbitrary = sized $ \n -> resize (smallish n) arbitrary+ where smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs++instance Arbitrary J.JSString where+ arbitrary = J.pack `fmap` arbitrary+ shrink = map J.pack . shrink . J.unpack++newtype BigInt = Big Integer+ deriving (Eq, Show)++instance Arbitrary BigInt where+ arbitrary = choose (1::Int,200) >>= \e -> Big <$> choose (10^(e-1),10^e)+ shrink (Big a) = [Big (a `div` 2^(l-e)) | e <- shrink l]+ where l = truncate (log (fromIntegral a) / log 2 :: Double) :: Integer++newtype BigBounded a = BigBounded a+ deriving (Eq, Show)++instance (Bounded a, Random a, Arbitrary a) => Arbitrary (BigBounded a) where+ arbitrary = BigBounded <$> choose (minBound, maxBound)++newtype NotEmpty a = NotEmpty { notEmpty :: a }+ deriving (Eq, Ord)++instance Show a => Show (NotEmpty a) where+ show (NotEmpty a) = show a++instance Functor NotEmpty where+ fmap f (NotEmpty a) = NotEmpty (f a)++instance Arbitrary a => Arbitrary (NotEmpty [a]) where+ arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))+ shrink = shrinkNotEmpty null++instance Arbitrary (NotEmpty J.JSString) where+ arbitrary = (fmap J.pack) `fmap` arbitrary+ shrink = shrinkNotEmpty J.null++instance Arbitrary (NotEmpty B.ByteString) where+ arbitrary = (fmap B.pack) `fmap` arbitrary+ shrink = shrinkNotEmpty B.null++shrinkNotEmpty :: Arbitrary a => (a -> Bool) -> NotEmpty a -> [NotEmpty a]+shrinkNotEmpty isNull (NotEmpty xs) =+ [ NotEmpty xs' | xs' <- shrink xs, not (isNull xs') ]++data Small = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7+ | S8 | S9 | S10 | S11 | S12 | S13 | S14 | S15+ | S16 | S17 | S18 | S19 | S20 | S21 | S22 | S23+ | S24 | S25 | S26 | S27 | S28 | S29 | S30 | S31+ deriving (Eq, Ord, Enum, Bounded)++small :: Integral a => Small -> a+small = fromIntegral . fromEnum++intf :: (Int -> Int -> Int) -> Small -> Small -> Small+intf f a b = toEnum ((fromEnum a `f` fromEnum b) `mod` 32)++instance Show Small where+ show = show . fromEnum++instance Read Small where+ readsPrec n = map (first toEnum) . readsPrec n++instance Num Small where+ fromInteger = toEnum . fromIntegral+ signum _ = 1+ abs = id+ (+) = intf (+)+ (-) = intf (-)+ (*) = intf (*)++instance Real Small where+ toRational = toRational . fromEnum++instance Integral Small where+ toInteger = toInteger . fromEnum+ quotRem a b = (toEnum x, toEnum y)+ where (x, y) = fromEnum a `quotRem` fromEnum b++instance Random Small where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Arbitrary Small where+ arbitrary = choose (minBound, maxBound)+ shrink = shrinkIntegral++integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,+ fromIntegral b :: Integer) g of+ (x,h) -> (fromIntegral x, h)++{-+data DecodeErr = Lenient | Ignore | Strict | Replace+ deriving (Show, Eq)++genDecodeErr :: DecodeErr -> Gen J.OnDecodeError+genDecodeErr Lenient = return J.lenientDecode+genDecodeErr Ignore = return J.ignore+genDecodeErr Strict = return J.strictDecode+genDecodeErr Replace = arbitrary++instance Arbitrary DecodeErr where+ arbitrary = elements [Lenient, Ignore, Strict, Replace]+-}++class Stringy s where+ packS :: String -> s+ unpackS :: s -> String+ splitAtS :: Int -> s -> (s,s)+ packSChunkSize :: Int -> String -> s+ packSChunkSize _ = packS++instance Stringy String where+ packS = id+ unpackS = id+ splitAtS = splitAt++instance Stringy (JF.Stream Char) where+ packS = JF.streamList+ unpackS = JF.unstreamList+ splitAtS n s = (JF.take n s, JF.drop n s)++instance Stringy J.JSString where+ packS = J.pack+ unpackS = J.unpack+ splitAtS = J.splitAt++-- Do two functions give the same answer?+eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool+eq a b s = a s =^= b s++-- What about with the RHS packed?+eqP :: (Eq a, Show a, Stringy s) =>+ (String -> a) -> (s -> a) -> String -> Word8 -> Bool+eqP f g s w = eql "orig" (f s) (g t) &&+ eql "mini" (f s) (g mini) &&+ eql "head" (f sa) (g ta) &&+ eql "tail" (f sb) (g tb)+ where t = packS s+ mini = packSChunkSize 10 s+ (sa,sb) = splitAt m s+ (ta,tb) = splitAtS m t+ l = length s+ m | l == 0 = n+ | otherwise = n `mod` l+ n = fromIntegral w+ eql d a b+ | a =^= b = True+ | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False++instance Arbitrary FPFormat where+ arbitrary = elements [Exponent, Fixed, Generic]++newtype Precision a = Precision (Maybe Int)+ deriving (Eq, Show)++precision :: a -> Precision a -> Maybe Int+precision _ (Precision prec) = prec++arbitraryPrecision :: Int -> Gen (Precision a)+arbitraryPrecision maxDigits = Precision <$> do+ n <- choose (-1,maxDigits)+ return $ if n == -1+ then Nothing+ else Just n++instance Arbitrary (Precision Float) where+ arbitrary = arbitraryPrecision 11+ shrink = map Precision . shrink . precision undefined++instance Arbitrary (Precision Double) where+ arbitrary = arbitraryPrecision 22+ shrink = map Precision . shrink . precision undefined++-- Work around lack of Show instance for TextEncoding.+data Encoding = E String IO.TextEncoding++instance Show Encoding where show (E n _) = "utf" ++ n++instance Arbitrary Encoding where+ arbitrary = oneof . map return $+ [ E "8" IO.utf8, E "8_bom" IO.utf8_bom, E "16" IO.utf16+ , E "16le" IO.utf16le, E "16be" IO.utf16be, E "32" IO.utf32+ , E "32le" IO.utf32le, E "32be" IO.utf32be+ ]++windowsNewlineMode :: IO.NewlineMode+windowsNewlineMode = IO.NewlineMode+ { IO.inputNL = IO.CRLF, IO.outputNL = IO.CRLF+ }++instance Arbitrary IO.NewlineMode where+ arbitrary = oneof . map return $+ [ IO.noNewlineTranslation, IO.universalNewlineMode, IO.nativeNewlineMode+ , windowsNewlineMode+ ]++instance Arbitrary IO.BufferMode where+ arbitrary = oneof [ return IO.NoBuffering,+ return IO.LineBuffering,+ return (IO.BlockBuffering Nothing),+ (IO.BlockBuffering . Just . (+1) . fromIntegral) `fmap`+ (arbitrary :: Gen Word16) ]++-- This test harness is complex! What property are we checking?+--+-- Reading after writing a multi-line file should give the same+-- results as were written.+--+-- What do we vary while checking this property?+-- * The lines themselves, scrubbed to contain neither CR nor LF. (By+-- working with a list of lines, we ensure that the data will+-- sometimes contain line endings.)+-- * Encoding.+-- * Newline translation mode.+-- * Buffering.+write_read :: (NFData a, Eq a)+ => ([b] -> a)+ -> ((Char -> Bool) -> a -> b)+ -> (IO.Handle -> a -> IO ())+ -> (IO.Handle -> IO a)+ -> Encoding+ -> IO.NewlineMode+ -> IO.BufferMode+ -> [a]+ -> Property+write_read unline filt writer reader (E _ _) nl buf ts =+ monadicIO $ assert . (==t) =<< run act+ where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts+ act = withTempFile $ \path h -> do+ -- hSetEncoding h enc+ IO.hSetNewlineMode h nl+ IO.hSetBuffering h buf+ () <- writer h t+ IO.hClose h+ bracket (IO.openFile path IO.ReadMode) IO.hClose $ \h' -> do+ -- hSetEncoding h' enc+ IO.hSetNewlineMode h' nl+ IO.hSetBuffering h' buf+ r <- reader h'+ r `deepseq` return r
+ test/Tests/Regressions.hs view
@@ -0,0 +1,86 @@+-- | Regression tests for specific bugs.+--+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+module Tests.Regressions+ (+ tests+ ) where+{-+import Control.Exception (SomeException, handle)+import System.IO+import Test.HUnit (assertBool, assertEqual, assertFailure)+import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LE+import qualified Data.Text.Unsafe as T+-}+import qualified Test.Framework as F+import qualified Test.Framework.Providers.HUnit as F+{-+import Tests.Utils (withTempFile)++-- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring+-- caused either a segfault or attempt to allocate a negative number+-- of bytes.+lazy_encode_crash :: IO ()+lazy_encode_crash = withTempFile $ \ _ h ->+ LB.hPut h . LE.encodeUtf8 . LT.pack . replicate 100000 $ 'a'++-- Reported by Pieter Laeremans: attempting to read an incorrectly+-- encoded file can result in a crash in the RTS (i.e. not merely an+-- exception).+hGetContents_crash :: IO ()+hGetContents_crash = withTempFile $ \ path h -> do+ B.hPut h (B.pack [0x78, 0xc4 ,0x0a]) >> hClose h+ h' <- openFile path ReadMode+ hSetEncoding h' utf8+ handle (\(_::SomeException) -> return ()) $+ T.hGetContents h' >> assertFailure "T.hGetContents should crash"++-- Reported by Ian Lynagh: attempting to allocate a sufficiently large+-- string (via either Array.new or Text.replicate) could result in an+-- integer overflow.+replicate_crash :: IO ()+replicate_crash = handle (\(_::SomeException) -> return ()) $+ T.replicate (2^power) "0123456789abcdef" `seq`+ assertFailure "T.replicate should crash"+ where+ power | maxBound == (2147483647::Int) = 28+ | otherwise = 60 :: Int++-- Reported by John Millikin: a UTF-8 decode error handler could+-- return a bogus substitution character, which we would write without+-- checking.+utf8_decode_unsafe :: IO ()+utf8_decode_unsafe = do+ let t = TE.decodeUtf8With (\_ _ -> Just '\xdc00') "\x80"+ assertBool "broken error recovery shouldn't break us" (t == "\xfffd")++-- Reported by Eric Seidel: we mishandled mapping Chars that fit in a+-- single Word16 to Chars that require two.+mapAccumL_resize :: IO ()+mapAccumL_resize = do+ let f a _ = (a, '\65536')+ count = 5+ val = T.mapAccumL f (0::Int) (T.replicate count "a")+ assertEqual "mapAccumL should correctly fill buffers for two-word results"+ (0, T.replicate count "\65536") val+ assertEqual "mapAccumL should correctly size buffers for two-word results"+ (count * 2) (T.lengthWord16 (snd val))+-}+tests :: F.Test+tests = F.testGroup "Regressions" []+{-+ F.testGroup "Regressions"+ [ F.testCase "hGetContents_crash" hGetContents_crash+ , F.testCase "lazy_encode_crash" lazy_encode_crash+ , F.testCase "mapAccumL_resize" mapAccumL_resize+ , F.testCase "replicate_crash" replicate_crash+ , F.testCase "utf8_decode_unsafe" utf8_decode_unsafe+ ]+-}
+ test/Tests/SlowFunctions.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE BangPatterns #-}+module Tests.SlowFunctions+ (+ indices+ , splitOn+ ) where++import qualified Data.JSString as J++indices :: J.JSString -- ^ Substring to search for (@needle@)+ -> J.JSString -- ^ Text to search in (@haystack@)+ -> [Int]+indices needle haystack+ | J.null needle = []+ | otherwise = scan 0+ where+ hlen = J.length haystack+ nlen = J.length needle+ scan i | i >= hlen = []+ | needle `J.isPrefixOf` (J.drop i haystack) = i : scan (i+nlen) -- slow!+ | otherwise = scan (i+1)+-- where t = J.drop i h -- Text harr (hoff+i) (hlen-i)+-- d = iter_ haystack i++splitOn :: J.JSString -- ^ Text to split on+ -> J.JSString -- ^ Input text+ -> [J.JSString]+splitOn pat src0+ | J.null pat = error "SPLsplitOn: empty"+-- - | l == 1 = J.split (== (J.head pat)) src0 -- (unsafeHead pat)) src0+ | otherwise = go src0+ where+ l = J.length pat+ go src = search 0 src+ where+ search !n !s+ | J.null s = [src] -- not found+ | pat `J.isPrefixOf` s = J.take n src : go (J.drop l s)+ | otherwise = search (n+1) (J.tail s) -- unsafeTail s)
+ test/Tests/Utils.hs view
@@ -0,0 +1,52 @@+-- | Miscellaneous testing utilities+--+{-# LANGUAGE ScopedTypeVariables #-}+module Tests.Utils+ (+ (=^=)+ , withRedirect+ , withTempFile+ ) where++import Control.Exception (SomeException, bracket, bracket_, evaluate, try)+import Control.Monad (when)+import Debug.Trace (trace)+import GHC.IO.Handle.Internals (withHandle)+import System.Directory (removeFile)+import System.IO (Handle, hClose, hFlush, hIsOpen, hIsWritable, openTempFile)+import System.IO.Unsafe (unsafePerformIO)++-- Ensure that two potentially bottom values (in the sense of crashing+-- for some inputs, not looping infinitely) either both crash, or both+-- give comparable results for some input.+(=^=) :: (Eq a, Show a) => a -> a -> Bool+i =^= j = unsafePerformIO $ do+ x <- try (evaluate i)+ y <- try (evaluate j)+ case (x,y) of+ (Left (_ :: SomeException), Left (_ :: SomeException))+ -> return True+ (Right a, Right b) -> return (a == b)+ e -> trace ("*** Divergence: " ++ show e) return False+infix 4 =^=+{-# NOINLINE (=^=) #-}++withTempFile :: (FilePath -> Handle -> IO a) -> IO a+withTempFile = bracket (openTempFile "." "crashy.txt") cleanupTemp . uncurry+ where+ cleanupTemp (path,h) = do+ open <- hIsOpen h+ when open (hClose h)+ removeFile path++withRedirect :: Handle -> Handle -> IO a -> IO a+withRedirect tmp h = bracket_ swap swap+ where+ whenM p a = p >>= (`when` a)+ swap = do+ whenM (hIsOpen tmp) $ whenM (hIsWritable tmp) $ hFlush tmp+ whenM (hIsOpen h) $ whenM (hIsWritable h) $ hFlush h+ withHandle "spam" tmp $ \tmph -> do+ hh <- withHandle "spam" h $ \hh ->+ return (tmph,hh)+ return (hh,())