packages feed

ghcjs-base-stub (empty) → 0.1.0.0

raw patch · 29 files changed

+3081/−0 lines, 29 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, deepseq, ghc-prim, primitive, scientific, text, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Louis Pan (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Louis Pan nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,14 @@+[![Hackage](https://img.shields.io/hackage/v/ghcjs-base-stub.svg)](https://hackage.haskell.org/package/ghcjs-base-stub)++Fake stubs for GHCJS base to allow GHCJS projects to be compiled using GHC.+This also allows developing under intero, and generating haddocks.++Usage:++Add the following to GHCJS project's cabal.+```+  if impl(ghcjs)+    build-depends: ghcjs-base+  if !impl(ghcjs)+    build-depends: ghcjs-base-stub+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghcjs-base-stub.cabal view
@@ -0,0 +1,60 @@+name:                ghcjs-base-stub+version:             0.1.0.0+synopsis:            Allow GHCJS projects to compile under GHC and develop using intero.+description:         Allow GHCJS projects to compile under GHC and develop using intero.+homepage:            https://github.com/louispan/javascript-stub#readme+license:             BSD3+license-file:        LICENSE+author:              Louis Pan+maintainer:          louis@pan.me+copyright:           2017 Louis Pan+category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  build-depends:       base >= 4.7 && < 5+  if !impl(ghcjs)+      other-modules:   GHCJS.Internal.Types+                       Data.JSString.Internal.Type+      exposed-modules: Data.JSString+                       Data.JSString.Internal.Fusion+                       Data.JSString.Internal.Fusion.CaseMapping+                       Data.JSString.Internal.Fusion.Common+                       Data.JSString.Internal.Fusion.Types+                       Data.JSString.Internal.Search+                       Data.JSString.Text+                       GHCJS.Concurrent+                       GHCJS.Foreign.Internal+                       GHCJS.Foreign+                       GHCJS.Foreign.Callback+                       GHCJS.Foreign.Callback.Internal+                       GHCJS.Foreign.Export+                       GHCJS.Marshal+                       GHCJS.Marshal.Internal+                       GHCJS.Marshal.Pure+                       GHCJS.Nullable+                       GHCJS.Prim+                       GHCJS.Types+                       JavaScript.Object+                       JavaScript.Object.Internal+                       JavaScript.Array+                       JavaScript.Array.Internal+      build-depends:   aeson >= 0.11 && < 1+                     , attoparsec >= 0.13 && < 1+                     , deepseq >= 1.4 && < 2+                     , ghc-prim+                     , primitive >= 0.6 && < 1+                     , scientific >= 0.3.4 && < 1+                     , text >= 1.2 && < 2+                     , transformers >= 0.5 && < 0.6+                     , unordered-containers >= 0.2.7 && < 1+                     , vector >= 0.11 && < 1+  default-language:    Haskell2010+  ghc-options:         -Wall++source-repository head+  type:     git+  location: https://github.com/louispan/ghcjs-base-stub
+ src/Data/JSString.hs view
@@ -0,0 +1,1118 @@+module Data.JSString+    ( JSString+    -- * Creation and elimination+    , pack+    , unpack+    , unpack'+    , singleton+    , empty+    -- * Basic interface+    , cons+    , snoc+    , append+    , uncons+    , head+    , last+    , tail+    , init+    , null+    , length+    , compareLength+    -- * Transformations+    , map+    , intercalate+    , intersperse+    , transpose+    , reverse+    , replace+    -- ** Case conversion+    , toCaseFold+    , toLower+    , toUpper+    , toTitle+                       -- ** Justification+    , justifyLeft+    , justifyRight+    , center+                       -- * Folds+    , foldl+    , foldl'+    , foldl1+    , foldl1'+    , foldr+    , foldr1+                       -- ** Special folds+    , concat+    , concatMap+    , any+    , all+    , maximum+    , minimum+                       -- * Construction+                       -- ** Scans+    , scanl+    , scanl1+    , scanr+    , scanr1+                       -- ** Accumulating maps+    , mapAccumL+    , mapAccumR+                       -- ** Generation and unfolding+    , replicate+    , unfoldr+    , unfoldrN+                       -- * Substrings+                       -- ** Breaking strings+    , take+    , takeEnd+    , drop+    , dropEnd+    , takeWhile+    , dropWhile+    , dropWhileEnd+    , dropAround+    , strip+    , stripStart+    , stripEnd+    , splitAt+    , breakOn+    , breakOnEnd+    , break+    , span+    , group+    , group'+    , groupBy+    , inits+    , tails+                       -- ** Breaking into many substrings+    , splitOn+    , splitOn'+    , split+    , chunksOf+    , chunksOf'+    -- ** Breaking into lines and words+    , lines+    , lines'+    , words+    , words'+    , unlines+    , unwords+    -- * Predicates+    , isPrefixOf+    , isSuffixOf+    , isInfixOf+    -- ** View patterns+    , stripPrefix+    , stripSuffix+    , commonPrefixes+    -- * Searching+    , filter+    , breakOnAll+    , breakOnAll'+    , find+    , partition+    -- * Indexing+    , index+    , findIndex+    , count+    -- * Zipping+    , zip+    , zipWith+    ) where+++import qualified Data.Text as T++import           Data.JSString.Internal.Type+import           GHC.Exts as Exts++import Prelude+       (Maybe, Bool, String, Ordering, (.),+        ($),fmap, (<$>))++-- | /O(1)/ The empty 'JSString'.+empty :: JSString+empty = JSString (T.empty)+{-# INLINE [1] empty #-}++getJSString :: JSString -> T.Text+getJSString (JSString txt) = txt++-- -----------------------------------------------------------------------------+-- * Conversion to/from 'JSString'++-- | /O(n)/ Convert a 'String' into a 'JSString'.  Subject to+-- fusion.+pack :: String -> JSString+pack = JSString . T.pack+{-# INLINE [1] pack #-}++-- | /O(n)/ Convert a 'JSString' into a 'String'.  Subject to fusion.+unpack :: JSString -> String+unpack = T.unpack . getJSString+{-# INLINE [1] unpack #-}++unpack' :: JSString -> String+unpack' = unpack+{-# INLINE unpack' #-}++-- | /O(1)/ Convert a character into a 'JSString'.  Subject to fusion.+-- Performs replacement on invalid scalar values.+singleton :: Char -> JSString+singleton = JSString . T.singleton+{-# INLINE [1] 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 (JSString x) = JSString $ T.cons c x+{-# INLINE [1] cons #-}++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 (JSString x) c = JSString $ T.snoc x c+  -- unstream (S.snoc (stream t) (safe c))+{-# INLINE [1] snoc #-}++-- | /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 (JSString x) (JSString y) = JSString $ T.append x y+{-# INLINE [1] append #-}++-- | /O(1)/ Returns the first character of a 'JSString', which must be+-- non-empty.  Subject to fusion.+head :: JSString -> Char+head (JSString x) = T.head x+{-# INLINE [1] head #-}+++-- | /O(1)/ Returns the first character and rest of a 'JSString', or+-- 'Nothing' if empty. Subject to fusion.+uncons :: JSString -> Maybe (Char, JSString)+uncons (JSString x) = (fmap JSString) <$> T.uncons x+{-# INLINE [1] uncons #-}++-- | /O(1)/ Returns the last character of a 'JSString', which must be+-- non-empty.  Subject to fusion.+last :: JSString -> Char+last (JSString x) = T.last x+{-# INLINE [1] last #-}++-- | /O(1)/ Returns all characters after the head of a 'JSString', which+-- must be non-empty.  Subject to fusion.+tail :: JSString -> JSString+tail (JSString x) = JSString $ T.tail x+{-# INLINE [1] tail #-}++-- | /O(1)/ Returns all but the last character of a 'JSString', which must+-- be non-empty.  Subject to fusion.+init :: JSString -> JSString+init (JSString x) = JSString $ T.init x+{-# INLINE [1] init #-}++-- | /O(1)/ Tests whether a 'JSString' is empty or not.  Subject to+-- fusion.+null :: JSString -> Bool+null (JSString x) = T.null x+{-# INLINE [1] null #-}++-- | /O(n)/ Returns the number of characters in a 'JSString'.+-- Subject to fusion.+length :: JSString -> Int+length (JSString x) = T.length x+{-# INLINE [1] length #-}+-- | /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 (JSString t) n = T.compareLength t n+{-# INLINE [1] compareLength #-}++-- -----------------------------------------------------------------------------+-- * Transformations+-- | /O(n)/ 'map' @f@ @t@ is the 'JSString' obtained by applying @f@ to+-- each element of @t@.  Subject to fusion.  Performs replacement on+-- invalid scalar values.+map :: (Char -> Char) -> JSString -> JSString+map f (JSString t) = JSString $ T.map f 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 (JSString i) xs = JSString $ T.intercalate i (getJSString <$> xs)+{-# INLINE [1] intercalate #-}++-- | /O(n)/ The 'intersperse' function takes a character and places it+-- between the characters of a 'JSString'.  Subject to fusion.  Performs+-- replacement on invalid scalar values.+intersperse     :: Char -> JSString -> JSString+intersperse c (JSString x) = JSString $ T.intersperse c x+{-# INLINE [1] intersperse #-}++-- | /O(n)/ Reverse the characters of a string. Subject to fusion.+reverse :: JSString -> JSString+reverse = JSString . T.reverse . getJSString+{-# INLINE [1] reverse #-}++-- | /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 (JSString needle) (JSString replacement) (JSString haystack) =+    JSString $ T.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 \"&#xfb13;\" (men now, U+FB13) is case+-- folded to the sequence \"&#x574;\" (men, U+0574) followed by+-- \"&#x576;\" (now, U+0576), while the Greek \"&#xb5;\" (micro sign,+-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)+-- instead of itself.+toCaseFold :: JSString -> JSString+toCaseFold = JSString . T.toCaseFold . getJSString+{-# INLINE [0] toCaseFold #-}++-- | /O(n)/ Convert a string to lower case, using simple case+-- conversion.  Subject to fusion.+--+-- The result string may be longer than the input string.  For+-- instance, \"&#x130;\" (Latin capital letter I with dot above,+-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)+-- followed by \" &#x307;\" (combining dot above, U+0307).+toLower :: JSString -> JSString+toLower = JSString . T.toLower . getJSString+{-# INLINE [1] toLower #-}+-- | /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 \"&#xdf;\" (eszett, U+00DF) maps to the+-- two-letter sequence \"SS\".+toUpper :: JSString -> JSString+toUpper = JSString . T.toUpper . getJSString+{-# INLINE [1] toUpper #-}++-- | /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 &#xfb02; (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&#x2014;but this function will+-- capitalize /every/ word.+toTitle :: JSString -> JSString+toTitle = JSString . T.toTitle . getJSString+{-# 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 (JSString t) = JSString $ T.justifyLeft k c t+{-# INLINE [1] justifyLeft #-}++-- | /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 (JSString t) = JSString $ T.justifyRight k c 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 (JSString t) = JSString $ T.center k c t+{-# INLINE center #-}++-- | /O(n)/ The 'transpose' function transposes the rows and columns+-- of its 'JSString' argument.  Note that this function uses 'pack',+-- 'unpack', and the list version of transpose, and is thus not very+-- efficient.+transpose :: [JSString] -> [JSString]+transpose ts = JSString <$> T.transpose (getJSString <$> 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 (JSString t) = T.foldl f z t+{-# INLINE foldl #-}++-- | /O(n)/ A strict version of 'foldl'.  Subject to fusion.+foldl' :: (a -> Char -> a) -> a -> JSString -> a+foldl' f z (JSString t) = T.foldl' f z 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 (JSString t) = T.foldl1 f t+{-# INLINE foldl1 #-}++-- | /O(n)/ A strict version of 'foldl1'.  Subject to fusion.+foldl1' :: (Char -> Char -> Char) -> JSString -> Char+foldl1' f (JSString t) = T.foldl1' f 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 (JSString t) = T.foldr f z 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 (JSString t) = T.foldr1 f t+{-# INLINE foldr1 #-}++-- -----------------------------------------------------------------------------+-- ** Special folds++-- | /O(n)/ Concatenate a list of 'JSString's.+concat :: [JSString] -> JSString+concat xs = JSString $ T.concat $ getJSString <$> xs++-- | /O(n)/ Map a function over a 'JSString' that results in a 'JSString', and+-- concatenate the results.+concatMap :: (Char -> JSString) -> JSString -> JSString+concatMap f (JSString t) = JSString $ T.concatMap (getJSString . f) t+{-# INLINE concatMap #-}++-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the+-- 'JSString' @t@ satisifes the predicate @p@. Subject to fusion.+any :: (Char -> Bool) -> JSString -> Bool+any p (JSString t) = T.any p 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 (JSString t) = T.all p 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 (JSString t) = T.maximum 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 (JSString t) = T.minimum 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 (JSString t) = JSString $ T.scanl f z t+{-# 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 (JSString x) = JSString $ T.scanl1 f x+{-# 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 c (JSString z) = JSString $ T.scanr f c z+{-# 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 (JSString t) = JSString $ T.scanr1 f 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 z (JSString t) = JSString <$> T.mapAccumL f z t+{-# 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 z (JSString t) = JSString <$> T.mapAccumR f z t+{-# 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 n (JSString t) = JSString $ T.replicate n t+{-# INLINE [1] replicate #-}++-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'+-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a+-- 'JSString' from a seed value. The function takes the element and+-- returns 'Nothing' if it is done producing the 'JSString', otherwise+-- 'Just' @(a,b)@.  In this case, @a@ is the next 'Char' in the+-- string, and @b@ is the seed value for further production. Subject+-- to fusion.  Performs replacement on invalid scalar values.+unfoldr     :: (a -> Maybe (Char,a)) -> a -> JSString+unfoldr f s = JSString $ T.unfoldr 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 = JSString $ T.unfoldrN n 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 n (JSString t) = JSString $ T.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+-}++-- | /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 n (JSString t) = JSString $ T.takeEnd n t+{-+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 n (JSString t) = JSString $ T.drop n t+{-# INLINE [1] drop #-}++-- | /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 (JSString x) = JSString $ T.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 (JSString x) = JSString $ T.takeWhile p x+{-# INLINE [1] takeWhile #-}++-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after+-- 'takeWhile' @p@ @t@. Subject to fusion.+dropWhile :: (Char -> Bool) -> JSString -> JSString+dropWhile p (JSString x) = JSString $ T.dropWhile p x+{-# INLINE [1] dropWhile #-}++-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after+-- dropping characters that fail the predicate @p@ from the end of+-- @t@.  Subject to fusion.+-- Examples:+--+-- > dropWhileEnd (=='.') "foo..." == "foo"+dropWhileEnd :: (Char -> Bool) -> JSString -> JSString+dropWhileEnd p (JSString x) = JSString $ T.dropWhileEnd p x+{-# INLINE [1] dropWhileEnd #-}++-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after+-- dropping characters that fail the predicate @p@ from both the+-- beginning and end of @t@.  Subject to fusion.+dropAround :: (Char -> Bool) -> JSString -> JSString+dropAround p (JSString t) = JSString $ T.dropAround p t+{-# INLINE [1] dropAround #-}++-- | /O(n)/ Remove leading white space from a string.  Equivalent to:+--+-- > dropWhile isSpace+stripStart :: JSString -> JSString+stripStart = JSString . T.stripStart . getJSString+{-# INLINE [1] stripStart #-}++-- | /O(n)/ Remove trailing white space from a string.  Equivalent to:+--+-- > dropWhileEnd isSpace+stripEnd :: JSString -> JSString+stripEnd = JSString . T.stripEnd . getJSString+{-# INLINE [1] stripEnd #-}++-- | /O(n)/ Remove leading and trailing white space from a string.+-- Equivalent to:+--+-- > dropAround isSpace+strip :: JSString -> JSString+strip = JSString . T.strip . getJSString+{-# 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 n (JSString t) = let (x, y) = T.splitAt n t in (JSString x, JSString y)+{-# 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 (JSString t) = let (x, y) = T.span p t in (JSString x, JSString y)+{-# 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 (JSString t) = let (x, y) = T.break p t in (JSString x, JSString y)+{-# INLINE break #-}++-- | /O(n)/ Group characters in a string according to a predicate.+groupBy :: (Char -> Char -> Bool) -> JSString -> [JSString]+groupBy p (JSString x) = JSString <$> T.groupBy p x++-- | /O(n)/ Group characters in a string by equality.+group :: JSString -> [JSString]+group (JSString x) = JSString <$> T.group x+{-# INLINE group #-}++group' :: JSString -> [JSString]+group' = group+{-# INLINE group' #-}++-- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest+-- first.+inits :: JSString -> [JSString]+inits (JSString x) = JSString <$> T.inits x++-- | /O(n^2)/ Return all final segments of the given 'JSString', longest+-- first.+tails :: JSString -> [JSString]+tails (JSString x) = JSString <$> T.tails x++-- $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 (JSString pat) (JSString src) = JSString <$> T.splitOn pat src+{-# INLINE [1] splitOn #-}++splitOn' :: JSString+         -- ^ String to split on. If this string is empty, an error+         -- will occur.+         -> JSString+         -- ^ Input text.+         -> [JSString]+splitOn' = splitOn+{-# NOINLINE splitOn' #-}+--- {-# INLINE [1] splitOn' #-}++-- | /O(n)/ Splits a 'JSString' into components delimited by separators,+-- where the predicate returns True for a separator element.  The+-- resulting components do not contain the separators.  Two adjacent+-- separators result in an empty component in the output.  eg.+--+-- > split (=='a') "aabbaca" == ["","","bb","c",""]+-- > split (=='a') ""        == [""]+split :: (Char -> Bool) -> JSString -> [JSString]+split p (JSString x) = JSString <$> T.split p x+{-# 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 n (JSString x) = JSString <$> T.chunksOf n x+{-# 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' = chunksOf+{-# INLINE chunksOf' #-}++-- ----------------------------------------------------------------------------+-- * Searching++-------------------------------------------------------------------------------+-- ** Searching with a predicate++-- | /O(n)/ The 'find' function takes a predicate and a 'JSString', and+-- returns the first element matching the predicate, or 'Nothing' if+-- there is no such element.+find :: (Char -> Bool) -> JSString -> Maybe Char+find p (JSString t) = T.find p 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 (JSString t) = let (x, y) = T.partition p t in (JSString x, JSString y)+{-# 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 (JSString t) = JSString $ T.filter p 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 (JSString pat) (JSString src) = let (x, y) = T.breakOn pat src in (JSString x, JSString y)+{-# 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 (JSString pat) (JSString src) = let (x, y) = T.breakOnEnd pat src in (JSString x, JSString y)+{-# 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 (JSString pat) (JSString src) = (\(x, y) -> (JSString x, JSString y)) <$> T.breakOnAll pat src+{-# INLINE breakOnAll #-}++breakOnAll' :: JSString              -- ^ @needle@ to search for+            -> JSString              -- ^ @haystack@ in which to search+            -> [(JSString, JSString)]+breakOnAll' = breakOnAll+{-# INLINE breakOnAll' #-}++-------------------------------------------------------------------------------+-- ** Indexing 'JSString's++-- $index+--+-- If you think of a 'JSString' value as an array of 'Char' values (which+-- it is not), you run the risk of writing inefficient code.+--+-- An idiom that is common in some languages is to find the numeric+-- offset of a character or substring, then use that number to split+-- or trim the searched string.  With a 'JSString' value, this approach+-- would require two /O(n)/ operations: one to perform the search, and+-- one to operate from wherever the search ended.+--+-- For example, suppose you have a string that you want to split on+-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of+-- searching for the index of @\"::\"@ and taking the substrings+-- before and after that index, you would instead use @breakOnAll \"::\"@.++-- | /O(n)/ 'JSString' index (subscript) operator, starting from 0.+index :: JSString -> Int -> Char+index (JSString t) n = T.index 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 (JSString t) = T.findIndex p 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 (JSString pat) (JSString src) = T.count pat src+{-# INLINE [1] count #-}++-------------------------------------------------------------------------------+-- * 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 (JSString a) (JSString b) = T.zip a b +{-# INLINE [0] zip #-}++-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function+-- given as the first argument, instead of a tupling function.+-- Performs replacement on invalid scalar values.+zipWith :: (Char -> Char -> Char) -> JSString -> JSString -> JSString+zipWith f (JSString t1) (JSString t2) = JSString $ T.zipWith f t1 t2+{-# INLINE [0] zipWith #-}++-- | /O(n)/ Breaks a 'JSString' up into a list of words, delimited by 'Char's+-- representing white space.+words :: JSString -> [JSString]+words (JSString x) = JSString <$> T.words x+{-# INLINE words #-}++-- fixme: strict words' that allocates the whole list in one go+words' :: JSString -> [JSString]+words' = words+{-# INLINE words' #-}++-- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at+-- newline 'Char's. The resulting strings do not contain newlines.+lines :: JSString -> [JSString]+lines (JSString ps) = JSString <$> T.lines ps+{-# INLINE lines #-}++lines' :: JSString -> [JSString]+lines' = lines+{-# INLINE lines' #-}++{-+-- | /O(n)/ Portably breaks a 'JSString' up into a list of 'JSString's at line+-- boundaries.+--+-- A line boundary is considered to be either a line feed, a carriage+-- return immediately followed by a line feed, or a carriage return.+-- This accounts for both Unix and Windows line ending conventions,+-- and for the old convention used on Mac OS 9 and earlier.+lines' :: Text -> [Text]+lines' ps | null ps   = []+          | otherwise = h : case uncons t of+                              Nothing -> []+                              Just (c,t')+                                  | c == '\n' -> lines t'+                                  | c == '\r' -> case uncons t' of+                                                   Just ('\n',t'') -> lines t''+                                                   _               -> lines t'+    where (h,t)    = span notEOL ps+          notEOL c = c /= '\n' && c /= '\r'++-}++-- | /O(n)/ Joins lines, after appending a terminating newline to+-- each.+unlines :: [JSString] -> JSString+unlines xs = JSString $ T.unlines $ getJSString <$> xs+{-# INLINE unlines #-}++-- | /O(n)/ Joins words using single space characters.+unwords :: [JSString] -> JSString+unwords xs = JSString $ T.unwords $ getJSString <$> 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 (JSString x) (JSString y) = T.isPrefixOf x y+{-# INLINE [1] isPrefixOf #-}++-- | /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 (JSString x) (JSString y) = T.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 (JSString needle) (JSString haystack) = T.isInfixOf needle haystack+{-# INLINE [1] isInfixOf #-}++-------------------------------------------------------------------------------+-- * 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 (JSString x) (JSString y) = JSString <$> T.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 (JSString x) (JSString y) = (\(a, b, c) -> (JSString a, JSString b, JSString c)) <$> T.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 (JSString x) (JSString y) = JSString <$> T.stripSuffix x y+{-# INLINE stripSuffix #-}++-- -----------------------------------------------------------------------------
+ src/Data/JSString/Internal/Fusion.hs view
@@ -0,0 +1,108 @@+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 Prelude hiding (length, reverse)++import Data.JSString.Internal.Type++import qualified Data.Text.Internal.Fusion as T+import Data.Text.Internal.Fusion (Stream(..), Step(..))++-- | /O(n)/ Convert a 'JSString' into a 'Stream Char'.+stream :: JSString -> Stream Char+stream (JSString t) = T.stream t+{-# INLINE [0] stream #-}++-- | /O(n)/ Convert a 'JSString' into a 'Stream Char', but iterate+-- backwards.+reverseStream :: JSString -> Stream Char+reverseStream (JSString x) = T.reverseStream x+{-# INLINE [0] reverseStream #-}++-- | /O(n)/ Convert a 'Stream Char' into a 'JSString'.+unstream :: Stream Char -> JSString+unstream strm = JSString $ T.unstream strm+{-# INLINE [0] unstream #-}+{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}+++-- ----------------------------------------------------------------------------+-- * Basic stream functions++length :: Stream Char -> Int+length = T.length+{-# INLINE[0] length #-}++-- | /O(n)/ Reverse the characters of a string.+reverse :: Stream Char -> JSString+reverse = JSString . T.reverse+{-# INLINE [0] reverse #-}++-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with+-- the input and result reversed.+reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char+reverseScanr = T.reverseScanr+{-# INLINE reverseScanr #-}++-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed+-- value. However, the length of the result is limited by the+-- first argument to 'unfoldrN'. This function is more efficient than+-- 'unfoldr' when the length of the result is known.+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char+unfoldrN = T.unfoldrN+{-# INLINE [0] unfoldrN #-}++-------------------------------------------------------------------------------+-- ** Indexing streams++-- | /O(n)/ stream index (subscript) operator, starting from 0.+index :: Stream Char -> Int -> Char+index = T.index+{-# 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 = T.findIndex+{-# 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 = T.countChar+{-# 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 z strm = JSString <$> T.mapAccumL f z strm+{-# INLINE [0] mapAccumL #-}
+ src/Data/JSString/Internal/Fusion/CaseMapping.hs view
@@ -0,0 +1,5 @@+module Data.JSString.Internal.Fusion.CaseMapping+    ( module Data.Text.Internal.Fusion.CaseMapping+    ) where++import Data.Text.Internal.Fusion.CaseMapping
+ src/Data/JSString/Internal/Fusion/Common.hs view
@@ -0,0 +1,5 @@+module Data.JSString.Internal.Fusion.Common+    ( module Data.Text.Internal.Fusion.Common+    ) where++import Data.Text.Internal.Fusion.Common
+ src/Data/JSString/Internal/Fusion/Types.hs view
@@ -0,0 +1,6 @@+module Data.JSString.Internal.Fusion.Types+    (+      module Data.Text.Internal.Fusion.Types+    ) where++import Data.Text.Internal.Fusion.Types
+ src/Data/JSString/Internal/Search.hs view
@@ -0,0 +1,5 @@+module Data.JSString.Internal.Search+    ( module Data.Text.Internal.Search+    ) where++import Data.Text.Internal.Search
+ src/Data/JSString/Internal/Type.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.JSString.Internal.Type where++import           Control.DeepSeq                      (NFData(..))+import           Data.Data+import qualified Data.Text as T+import           GHC.Exts as Exts+import           GHCJS.Internal.Types+import           GHCJS.Prim++newtype JSString = JSString T.Text+    deriving (Exts.IsString, Monoid, Eq, Ord, Data, Show, Read)++instance IsJSVal JSString where+    jsval_ _ = JSVal ()++instance NFData JSString where+    rnf !_ = ()
+ src/Data/JSString/Text.hs view
@@ -0,0 +1,42 @@+module Data.JSString.Text+    ( textToJSString+    , textFromJSString+    , lazyTextToJSString+    , lazyTextFromJSString+    , textFromJSVal+    , lazyTextFromJSVal+    ) where++import GHCJS.Prim++import Data.JSString.Internal.Type++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+++textToJSString :: T.Text -> JSString+textToJSString = JSString+{-# INLINE textToJSString #-}++textFromJSString :: JSString -> T.Text+textFromJSString (JSString t) = t+{-# INLINE  textFromJSString #-}++lazyTextToJSString :: TL.Text -> JSString+lazyTextToJSString t = JSString $ TL.toStrict t+{-# INLINE lazyTextToJSString #-}++lazyTextFromJSString :: JSString -> TL.Text+lazyTextFromJSString (JSString t) = TL.fromStrict t+{-# INLINE lazyTextFromJSString #-}++-- | returns the empty Text if not a string+textFromJSVal :: JSVal -> T.Text+textFromJSVal _ = T.empty+{-# INLINE textFromJSVal #-}++-- | returns the empty Text if not a string+lazyTextFromJSVal :: JSVal -> TL.Text+lazyTextFromJSVal _ = TL.empty+{-# INLINE lazyTextFromJSVal #-}
+ src/GHCJS/Concurrent.hs view
@@ -0,0 +1,96 @@+{-# 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           GHC.Conc.Sync (ThreadId(..))++import           Data.Bits (testBit)+import           Data.Data++{- |+     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 = id+{-# 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 = id+{-# 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++syncThreadState :: ThreadId -> IO Int+syncThreadState _ = pure 0++-- ----------------------------------------------------------------------------
+ src/GHCJS/Foreign.hs view
@@ -0,0 +1,63 @@+{-# 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+                     , jsTypeOf, JSType(..)+                     , jsonTypeOf, JSONType(..)+                     ) where++import           GHCJS.Types+import           GHCJS.Foreign.Internal
+ src/GHCJS/Foreign/Callback.hs view
@@ -0,0 +1,134 @@+{-# 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.Foreign.Callback.Internal+import           GHCJS.Prim+import           GHCJS.Types++{- |+     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 _ = pure ()++{- | 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 _ _ = pure (Callback nullRef)+++{- | 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 _ _ = pure (Callback nullRef)+++{- | 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 _ _ = pure (Callback nullRef)++{- | 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 _ _ = pure (Callback nullRef)++{- | 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' _ = pure (Callback nullRef)++syncCallback1' :: (JSVal -> IO JSVal)+               -> IO (Callback (JSVal -> IO JSVal))+syncCallback1' _ = pure (Callback nullRef)++syncCallback2' :: (JSVal -> JSVal -> IO JSVal)+               -> IO (Callback (JSVal -> JSVal -> IO JSVal))+syncCallback2' _ = pure (Callback nullRef)++syncCallback3' :: (JSVal -> JSVal -> JSVal -> IO JSVal)+               -> IO (Callback (JSVal -> JSVal -> JSVal -> IO JSVal))+syncCallback3' _ = pure (Callback nullRef)++{- | 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 _ = pure (Callback nullRef)++asyncCallback1 :: (JSVal -> IO ())            -- ^ the function that the callback calls+               -> IO (Callback (JSVal -> IO ())) -- ^ the calback+asyncCallback1 _ = pure (Callback nullRef)++asyncCallback2 :: (JSVal -> JSVal -> IO ())            -- ^ the Haskell function that the callback calls+               -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback+asyncCallback2 _ = pure (Callback nullRef)++asyncCallback3 :: (JSVal -> JSVal -> JSVal -> IO ())               -- ^ the Haskell function that the callback calls+               -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback+asyncCallback3 _ = pure (Callback nullRef)++-- ----------------------------------------------------------------------------
+ src/GHCJS/Foreign/Callback/Internal.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveDataTypeable #-}++module GHCJS.Foreign.Callback.Internal where++import GHCJS.Types++import Data.Typeable++newtype Callback a = Callback JSVal deriving Typeable+instance IsJSVal (Callback a)
+ src/GHCJS/Foreign/Export.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# 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 Data.Typeable++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 _ = pure (Export nullRef)++{- |+     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 _ f = f (Export nullRef)++{- |+     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 _ = pure Nothing++{- |+     Release all memory associated with the export. Subsequent calls to+     'derefExport' will return 'Nothing'+ -}+releaseExport :: Export a -> IO ()+releaseExport _ = pure ()++-- ----------------------------------------------------------------------------
+ src/GHCJS/Foreign/Internal.hs view
@@ -0,0 +1,152 @@+{-# 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+                              ) where++import           GHCJS.Types+import qualified GHCJS.Prim as Prim++import           Data.Typeable (Typeable)++-- 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 _ = False+{-# INLINE fromJSBool #-}++toJSBool :: Bool -> JSVal+toJSBool _ = jsNull+{-# INLINE toJSBool #-}++jsTrue :: JSVal+jsTrue = jsNull+{-# INLINE jsTrue #-}++jsFalse :: JSVal+jsFalse = Prim.jsNull+{-# INLINE jsFalse #-}++jsNull :: JSVal+jsNull = jsNull+{-# INLINE jsNull #-}++jsUndefined :: JSVal+jsUndefined = jsNull+{-# INLINE jsUndefined #-}++-- check whether a reference is `truthy' in the JavaScript sense+isTruthy :: JSVal -> Bool+isTruthy _ = False+{-# INLINE isTruthy #-}++isObject :: JSVal -> Bool+isObject _ = False+{-# INLINE isObject #-}++isNumber :: JSVal -> Bool+isNumber _ = False+{-# INLINE isNumber #-}++isString :: JSVal -> Bool+isString _ = False+{-# INLINE isString #-}++isBoolean :: JSVal -> Bool+isBoolean _ = False+{-# INLINE isBoolean #-}++isFunction :: JSVal -> Bool+isFunction _ = False+{-# INLINE isFunction #-}++isSymbol :: JSVal -> Bool+isSymbol _ = False+{-# INLINE isSymbol #-}++jsTypeOf :: JSVal -> JSType+jsTypeOf _ = Undefined+{-# INLINE jsTypeOf #-}++jsonTypeOf :: JSVal -> JSONType+jsonTypeOf _ = JSONNull+{-# INLINE jsonTypeOf #-}
+ src/GHCJS/Internal/Types.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module GHCJS.Internal.Types where++import Data.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+  default jsval_ :: Coercible a JSVal => a -> JSVal+  jsval_ _ = JSVal ()+  {-# 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
+ src/GHCJS/Marshal.hs view
@@ -0,0 +1,279 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# 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.Monad+import           Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)++import qualified Data.Aeson as AE+import qualified Data.HashMap.Strict as H+import           Data.Int (Int8, Int16, Int32)+import qualified Data.JSString.Text as JSS+import           Data.Scientific (Scientific, scientific, fromFloatDigits)+import           Data.Text (Text)+import qualified Data.Vector as V+import           Data.Word (Word8, Word16, Word32, Word)++import           GHCJS.Types+import           GHCJS.Foreign.Internal+import           GHCJS.Marshal.Pure+++import qualified JavaScript.Array.Internal  as AI+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 _ = pure nullRef+    {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c) => ToJSVal (a,b,c) where+    toJSVal _ = pure nullRef+    {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d) => ToJSVal (a,b,c,d) where+    toJSVal _ = pure nullRef+    {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e) => ToJSVal (a,b,c,d,e) where+    toJSVal _ = pure nullRef+    {-# INLINE toJSVal #-}+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f) => ToJSVal (a,b,c,d,e,f) where+    toJSVal _ = pure nullRef+    {-# 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 _ = pure nullRef+    {-# INLINE toJSVal #-}++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'
+ src/GHCJS/Marshal/Internal.hs view
@@ -0,0 +1,260 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+{-# 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.Monad++import           Data.Data+import           Data.Maybe++import           GHC.Generics++import qualified GHCJS.Prim                 as Prim+import qualified GHCJS.Foreign              as F+import           GHCJS.Types++import           JavaScript.Array           (MutableJSArray)+import qualified JavaScript.Array.Internal  as AI+import qualified JavaScript.Object.Internal as OI++import qualified Data.JSString as JSS++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+      Nothing -> 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.pack
+ src/GHCJS/Marshal/Pure.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MagicHash #-}+{-# 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.Int (Int8, Int16, Int32)+import           Data.JSString.Internal.Type+import           Data.Text (Text)+import           Data.Word (Word8, Word16, Word32, Word)+import           Data.JSString as JSS+import           Data.JSString.Text++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 _ = JSS.empty+                                   {-# INLINE pFromJSVal #-}+instance PFromJSVal [Char] where pFromJSVal   = Prim.fromJSString+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Text   where pFromJSVal   = textFromJSVal+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Char   where pFromJSVal _ = '?'+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Bool   where pFromJSVal _ = False+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Int    where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Int8   where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Int16  where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Int32  where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Word   where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Word8  where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Word16 where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Word32 where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Float  where pFromJSVal _ = 0+                                 {-# INLINE pFromJSVal #-}+instance PFromJSVal Double where pFromJSVal _ = 0+                                 {-# 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 _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Bool      where pToJSVal True     = jsTrue+                                  pToJSVal False    = jsFalse+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Int       where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Int8      where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Int16     where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Int32     where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Word      where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Word8     where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Word16    where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Word32    where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Float     where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}+instance PToJSVal Double    where pToJSVal _ = nullRef+                                  {-# INLINE pToJSVal #-}++instance PToJSVal a => PToJSVal (Maybe a) where+    pToJSVal Nothing  = jsNull+    pToJSVal (Just a) = pToJSVal a+    {-# INLINE pToJSVal #-}
+ src/GHCJS/Nullable.hs view
@@ -0,0 +1,18 @@+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 #-}+
+ src/GHCJS/Prim.hs view
@@ -0,0 +1,112 @@+module GHCJS.Prim+    ( JSVal(..)+    , WouldBlockException(..)+    , JSException(..)+    , mkJSException+    , fromJSString+    , toJSString+    , toJSArray+    , fromJSArray+    , fromJSInt+    , toJSInt+    , isNull+    , isUndefined+    , jsNull+    , getProp+    , getProp'+    ) where++import           Data.Typeable (Typeable)+import           Unsafe.Coerce (unsafeCoerce)++import qualified GHC.Exception as Ex++--- START Shim-specific+{-+  JSVal is a boxed type that can be used as FFI+  argument or result.+-}+newtype JSVal = JSVal ()+--- END Shim-specific++{-+  When a JavaScript exception is raised inside+  a safe or interruptible foreign call, it is converted+  to a JSException+ -}+data JSException = JSException JSVal String+  deriving (Typeable)++instance Ex.Exception JSException++instance Show JSException where+  show (JSException _ xs) = "JavaScript exception: " ++ xs++mkJSException :: JSVal -> IO JSException+mkJSException ref =+  return (JSException (unsafeCoerce ref) (fromJSString ref))++{- | Low-level conversion utilities for packages that cannot+     depend on ghcjs-base+ -}++{- | returns an empty string if the JSVal does not contain+     a string+ -}+fromJSString :: JSVal -> String+fromJSString = const mempty+{-# INLINE fromJSString #-}++toJSString :: String -> JSVal+toJSString = const jsNull+{-# INLINE toJSString #-}++fromJSArray :: JSVal -> IO [JSVal]+fromJSArray = pure mempty+{-# INLINE fromJSArray #-}++toJSArray :: [JSVal] -> IO JSVal+toJSArray = const $ pure jsNull+{-# INLINE toJSArray #-}++{- | returns zero if the JSVal does not contain a number+ -}+fromJSInt :: JSVal -> Int+fromJSInt = const 0+{-# INLINE fromJSInt #-}++toJSInt :: Int -> JSVal+toJSInt = const jsNull+{-# INLINE toJSInt #-}++isNull :: JSVal -> Bool+isNull = const True+{-# INLINE isNull #-}++isUndefined :: JSVal -> Bool+isUndefined = const True+{-# INLINE isUndefined #-}++jsNull :: JSVal+jsNull = JSVal ()+{-# INLINE jsNull #-}++getProp :: JSVal -> String -> IO JSVal+getProp _ _ = pure jsNull+{-# INLINE getProp #-}++getProp' :: JSVal -> JSVal -> IO JSVal+getProp' _ _ = pure jsNull+{-# INLINE getProp' #-}++{- | If a synchronous thread tries to do something that can only+     be done asynchronously, and the thread is set up to not+     continue asynchronously, it receives this exception.+ -}+data WouldBlockException = WouldBlockException+  deriving (Typeable)++instance Show WouldBlockException where+  show _ = "thread would block"++instance Ex.Exception WouldBlockException
+ src/GHCJS/Types.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++module GHCJS.Types ( JSVal+                   , WouldBlockException(..)+                   , JSException(..)+                   , IsJSVal+                   , jsval+                   , isNull+                   , isUndefined+                   , nullRef+                   , JSString+                   , mkRef+                   , Ref#+                   , toPtr+                   , fromPtr+                   , JSRef+                   ) where++import Foreign.Ptr++import Data.JSString.Internal.Type (JSString)+import GHCJS.Internal.Types++import GHCJS.Prim++import GHC.Exts++type Ref# = ByteArray#++mkRef :: ByteArray# -> JSVal+mkRef _ = nullRef++nullRef :: JSVal+nullRef = jsNull++toPtr :: JSVal -> Ptr a+toPtr _ = nullPtr++fromPtr :: Ptr a -> JSVal+fromPtr _ = nullRef++-- | 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 " #-}
+ src/JavaScript/Array.hs view
@@ -0,0 +1,41 @@+{-# 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           GHCJS.Types++import           JavaScript.Array.Internal++(!) :: JSArray -> Int -> JSVal+x ! n = index n x+{-# INLINE (!) #-}
+ src/JavaScript/Array/Internal.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, DataKinds, KindSignatures,+             PolyKinds, UnboxedTuples, GHCForeignImportPrim, DeriveDataTypeable,+             UnliftedFFITypes, MagicHash+  #-}+module JavaScript.Array.Internal where++import           Prelude hiding (length, reverse, drop, take)++import           Data.Typeable++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 = pure (SomeJSArray nullRef)+{-# INLINE create #-}++length :: JSArray -> Int+length _ = 0+{-# INLINE length #-}++lengthIO :: SomeJSArray m -> IO Int+lengthIO _ = pure 0+{-# INLINE lengthIO #-}++null :: JSArray -> Bool+null _ = True+{-# INLINE null #-}++append :: SomeJSArray m -> SomeJSArray m -> IO (SomeJSArray m1)+append _ _ = pure (SomeJSArray nullRef)+{-# INLINE append #-}++fromList :: [JSVal] -> JSArray+fromList _ = SomeJSArray nullRef+{-# INLINE fromList #-}++fromListIO :: [JSVal] -> IO (SomeJSArray m)+fromListIO _ = pure (SomeJSArray nullRef)+{-# INLINE fromListIO #-}++toList :: JSArray -> [JSVal]+toList _ = []+{-# INLINE toList #-}++toListIO :: SomeJSArray m -> IO [JSVal]+toListIO _ = pure []+{-# INLINE toListIO #-}++index :: Int -> JSArray -> JSVal+index _ _ = nullRef+{-# INLINE index #-}++read :: Int -> SomeJSArray m -> IO JSVal+read _ _ = pure nullRef+{-# INLINE read #-}++write :: Int -> JSVal -> MutableJSArray -> IO ()+write _ _ _ = pure ()+{-# INLINE write #-}++push :: JSVal -> MutableJSArray -> IO ()+push _ _ = pure ()+{-# INLINE push #-}++pop :: MutableJSArray -> IO JSVal+pop _  = pure nullRef+{-# INLINE pop #-}++unshift :: JSVal -> MutableJSArray -> IO ()+unshift _ _ = pure ()+{-# INLINE unshift #-}++shift :: MutableJSArray -> IO JSVal+shift _ = pure nullRef+{-# INLINE shift #-}++reverse :: MutableJSArray -> IO ()+reverse _ = pure ()+{-# INLINE reverse #-}++take :: Int -> JSArray -> JSArray+take _ _ = SomeJSArray nullRef+{-# INLINE take #-}++takeIO :: Int -> SomeJSArray m -> IO (SomeJSArray m1)+takeIO _ _ = pure (SomeJSArray nullRef)+{-# INLINE takeIO #-}++drop :: Int -> JSArray -> JSArray+drop _ _ = SomeJSArray nullRef+{-# INLINE drop #-}++dropIO :: Int -> SomeJSArray m -> IO (SomeJSArray m1)+dropIO _ _ = pure (SomeJSArray nullRef)+{-# INLINE dropIO #-}++sliceIO :: Int -> Int -> JSArray -> IO (SomeJSArray m1)+sliceIO _ _ _ = pure (SomeJSArray nullRef)+{-# INLINE sliceIO #-}++slice :: Int -> Int -> JSArray -> JSArray+slice _ _ _= SomeJSArray nullRef+{-# INLINE slice #-}++freeze :: MutableJSArray -> IO JSArray+freeze _ = pure (SomeJSArray nullRef)+{-# INLINE freeze #-}++unsafeFreeze :: MutableJSArray -> IO JSArray+unsafeFreeze (SomeJSArray x) = pure (SomeJSArray x)+{-# INLINE unsafeFreeze #-}++thaw :: JSArray -> IO MutableJSArray+thaw _ = pure (SomeJSArray nullRef)+{-# INLINE thaw #-}++unsafeThaw :: JSArray -> IO MutableJSArray+unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)+{-# INLINE unsafeThaw #-}+++-- -----------------------------------------------------------------------------
+ src/JavaScript/Object.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE UnboxedTuples #-}++module JavaScript.Object ( Object+                         , create+                         , getProp, unsafeGetProp+                         , setProp, unsafeSetProp+                         , allProps, listProps+                         , isInstanceOf+                         ) where++import           JavaScript.Object.Internal (Object(..))+import           JavaScript.Object.Internal -- as I
+ src/JavaScript/Object/Internal.hs view
@@ -0,0 +1,69 @@+{-# 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)++newtype Object = Object JSVal deriving (Typeable)+instance IsJSVal Object++-- | create an empty object+create :: IO Object+create = pure (Object nullRef)+{-# INLINE create #-}++allProps :: Object -> IO JSArray+allProps _ = pure $ JA.fromList []+{-# INLINE allProps #-}++listProps :: Object -> IO [JSString]+listProps _ = pure []+{-# 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 _ _ = pure nullRef+{-# INLINE getProp #-}++unsafeGetProp :: JSString -> Object -> IO JSVal+unsafeGetProp _ _ = pure nullRef+{-# INLINE unsafeGetProp #-}++setProp :: JSString -> JSVal -> Object -> IO ()+setProp _ _ _ = pure ()+{-# INLINE setProp #-}++unsafeSetProp :: JSString -> JSVal -> Object -> IO ()+unsafeSetProp _ _ _ = pure ()+{-# INLINE unsafeSetProp #-}++isInstanceOf :: Object -> JSVal -> Bool+isInstanceOf _ _ = False+{-# INLINE isInstanceOf #-}