diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Louis Pan (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Louis Pan nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghcjs-base-stub.cabal b/ghcjs-base-stub.cabal new file mode 100644 --- /dev/null +++ b/ghcjs-base-stub.cabal @@ -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 diff --git a/src/Data/JSString.hs b/src/Data/JSString.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSString.hs @@ -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 +-- . + +-- | /O(n)/ Convert a string to folded case. Subject to fusion. +-- +-- This function is mainly useful for performing caseless (also known +-- as case insensitive) string comparisons. +-- +-- A string @x@ is a caseless match for a string @y@ if and only if: +-- +-- @toCaseFold x == toCaseFold y@ +-- +-- The result string may be longer than the input string, and may +-- differ from applying 'toLower' to the input string. For instance, +-- the Armenian small ligature \"ﬓ\" (men now, U+FB13) is case +-- folded to the sequence \"մ\" (men, U+0574) followed by +-- \"ն\" (now, U+0576), while the Greek \"µ\" (micro sign, +-- U+00B5) is case folded to \"μ\" (small letter mu, U+03BC) +-- instead of itself. +toCaseFold :: JSString -> JSString +toCaseFold = 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, \"İ\" (Latin capital letter I with dot above, +-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069) +-- followed by \" ̇\" (combining dot above, U+0307). +toLower :: JSString -> JSString +toLower = 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 \"ß\" (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 fl (U+FB02) is converted to the +-- sequence Latin capital letter F (U+0046) followed by Latin small +-- letter l (U+006C). +-- +-- /Note/: this function does not take language or culture specific +-- rules into account. For instance, in English, different style +-- guides disagree on whether the book name \"The Hill of the Red +-- Fox\" is correctly title cased—but this function will +-- capitalize /every/ word. +toTitle :: JSString -> JSString +toTitle = 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 #-} + +-- ----------------------------------------------------------------------------- diff --git a/src/Data/JSString/Internal/Fusion.hs b/src/Data/JSString/Internal/Fusion.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSString/Internal/Fusion.hs @@ -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 #-} diff --git a/src/Data/JSString/Internal/Fusion/CaseMapping.hs b/src/Data/JSString/Internal/Fusion/CaseMapping.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSString/Internal/Fusion/CaseMapping.hs @@ -0,0 +1,5 @@ +module Data.JSString.Internal.Fusion.CaseMapping + ( module Data.Text.Internal.Fusion.CaseMapping + ) where + +import Data.Text.Internal.Fusion.CaseMapping diff --git a/src/Data/JSString/Internal/Fusion/Common.hs b/src/Data/JSString/Internal/Fusion/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSString/Internal/Fusion/Common.hs @@ -0,0 +1,5 @@ +module Data.JSString.Internal.Fusion.Common + ( module Data.Text.Internal.Fusion.Common + ) where + +import Data.Text.Internal.Fusion.Common diff --git a/src/Data/JSString/Internal/Fusion/Types.hs b/src/Data/JSString/Internal/Fusion/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSString/Internal/Fusion/Types.hs @@ -0,0 +1,6 @@ +module Data.JSString.Internal.Fusion.Types + ( + module Data.Text.Internal.Fusion.Types + ) where + +import Data.Text.Internal.Fusion.Types diff --git a/src/Data/JSString/Internal/Search.hs b/src/Data/JSString/Internal/Search.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSString/Internal/Search.hs @@ -0,0 +1,5 @@ +module Data.JSString.Internal.Search + ( module Data.Text.Internal.Search + ) where + +import Data.Text.Internal.Search diff --git a/src/Data/JSString/Internal/Type.hs b/src/Data/JSString/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSString/Internal/Type.hs @@ -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 !_ = () diff --git a/src/Data/JSString/Text.hs b/src/Data/JSString/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSString/Text.hs @@ -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 #-} diff --git a/src/GHCJS/Concurrent.hs b/src/GHCJS/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Concurrent.hs @@ -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 + +-- ---------------------------------------------------------------------------- diff --git a/src/GHCJS/Foreign.hs b/src/GHCJS/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Foreign.hs @@ -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 diff --git a/src/GHCJS/Foreign/Callback.hs b/src/GHCJS/Foreign/Callback.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Foreign/Callback.hs @@ -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) + +-- ---------------------------------------------------------------------------- diff --git a/src/GHCJS/Foreign/Callback/Internal.hs b/src/GHCJS/Foreign/Callback/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Foreign/Callback/Internal.hs @@ -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) diff --git a/src/GHCJS/Foreign/Export.hs b/src/GHCJS/Foreign/Export.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Foreign/Export.hs @@ -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 () + +-- ---------------------------------------------------------------------------- diff --git a/src/GHCJS/Foreign/Internal.hs b/src/GHCJS/Foreign/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Foreign/Internal.hs @@ -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 #-} diff --git a/src/GHCJS/Internal/Types.hs b/src/GHCJS/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Internal/Types.hs @@ -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 diff --git a/src/GHCJS/Marshal.hs b/src/GHCJS/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Marshal.hs @@ -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' diff --git a/src/GHCJS/Marshal/Internal.hs b/src/GHCJS/Marshal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Marshal/Internal.hs @@ -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 diff --git a/src/GHCJS/Marshal/Pure.hs b/src/GHCJS/Marshal/Pure.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Marshal/Pure.hs @@ -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 #-} diff --git a/src/GHCJS/Nullable.hs b/src/GHCJS/Nullable.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Nullable.hs @@ -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 #-} + diff --git a/src/GHCJS/Prim.hs b/src/GHCJS/Prim.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Prim.hs @@ -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 diff --git a/src/GHCJS/Types.hs b/src/GHCJS/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Types.hs @@ -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 " #-} diff --git a/src/JavaScript/Array.hs b/src/JavaScript/Array.hs new file mode 100644 --- /dev/null +++ b/src/JavaScript/Array.hs @@ -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 (!) #-} diff --git a/src/JavaScript/Array/Internal.hs b/src/JavaScript/Array/Internal.hs new file mode 100644 --- /dev/null +++ b/src/JavaScript/Array/Internal.hs @@ -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 #-} + + +-- ----------------------------------------------------------------------------- diff --git a/src/JavaScript/Object.hs b/src/JavaScript/Object.hs new file mode 100644 --- /dev/null +++ b/src/JavaScript/Object.hs @@ -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 diff --git a/src/JavaScript/Object/Internal.hs b/src/JavaScript/Object/Internal.hs new file mode 100644 --- /dev/null +++ b/src/JavaScript/Object/Internal.hs @@ -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 #-}