module Haste.JSString (
empty, singleton, pack, cons, snoc, append, replicate,
unpack, head, last, tail, drop, take, init, splitAt,
null, length, any, all,
map, reverse, intercalate, foldl', foldr, concat, concatMap,
RegEx, match, matches, regex, replace
) where
import qualified Data.List
import Prelude hiding (foldr, concat, concatMap, reverse, map, all, any,
length, null, splitAt, init, take, drop, tail, head,
last, replicate)
import Data.String
import Haste.Prim
import Haste.Prim.Foreign
#ifdef __HASTE__
import GHC.Prim
import System.IO.Unsafe
d2c :: Double -> Char
d2c d = unsafeCoerce# d
_jss_singleton :: Char -> IO JSString
_jss_singleton = ffi "String.fromCharCode"
_jss_cons :: Char -> JSString -> IO JSString
_jss_cons = ffi "(function(c,s){return String.fromCharCode(c)+s;})"
_jss_snoc :: JSString -> Char -> IO JSString
_jss_snoc = ffi "(function(s,c){return s+String.fromCharCode(c);})"
_jss_append :: JSString -> JSString -> IO JSString
_jss_append = ffi "(function(a,b){return a+b;})"
_jss_len :: JSString -> IO Int
_jss_len = ffi "(function(s){return s.length;})"
_jss_index :: JSString -> Int -> IO Double
_jss_index = ffi "(function(s,i){return s.charCodeAt(i);})"
_jss_substr :: JSString -> Int -> IO JSString
_jss_substr = ffi "(function(s,x){return s.substr(x);})"
_jss_take :: Int -> JSString -> IO JSString
_jss_take = ffi "(function(n,s){return s.substr(0,n);})"
_jss_rev :: JSString -> IO JSString
_jss_rev = ffi "(function(s){return s.split('').reverse().join('');})"
_jss_re_match :: JSString -> RegEx -> IO Bool
_jss_re_match = ffi "(function(s,re){return s.search(re)>=0;})"
_jss_re_compile :: JSString -> JSString -> IO RegEx
_jss_re_compile = ffi "(function(re,fs){return new RegExp(re,fs);})"
_jss_re_replace :: JSString -> RegEx -> JSString -> IO JSString
_jss_re_replace = ffi "(function(s,re,rep){return s.replace(re,rep);})"
_jss_re_find :: RegEx -> JSString -> IO [JSString]
_jss_re_find = ffi "(function(re,s) {\
var a = s.match(re);\
return a ? a : [];})"
{-# INLINE _jss_map #-}
_jss_map :: (Char -> Char) -> JSString -> JSString
_jss_map f s = veryUnsafePerformIO $ cmap_js (_jss_singleton . f) s
{-# INLINE _jss_cmap #-}
_jss_cmap :: (Char -> JSString) -> JSString -> JSString
_jss_cmap f s = veryUnsafePerformIO $ cmap_js (return . f) s
cmap_js :: (Char -> IO JSString) -> JSString -> IO JSString
cmap_js = ffi "(function(f,s){\
var s2 = '';\
for(var i in s) {\
s2 += f(s.charCodeAt(i));\
}\
return s2;})"
{-# INLINE _jss_foldl #-}
_jss_foldl :: (ToAny a, FromAny a) => (a -> Char -> a) -> a -> JSString -> a
_jss_foldl f x s = fromOpaque . unsafePerformIO $ do
foldl_js (\a c -> toOpaque $ f (fromOpaque a) c) (toOpaque x) s
foldl_js :: (Opaque a -> Char -> Opaque a)
-> Opaque a
-> JSString
-> IO (Opaque a)
foldl_js = ffi "(function(f,x,s){\
for(var i in s) {\
x = f(x,s.charCodeAt(i));\
}\
return x;})"
_jss_foldr :: (ToAny a, FromAny a) => (Char -> a -> a) -> a -> JSString -> a
_jss_foldr f x s = fromOpaque . unsafePerformIO $ do
foldr_js (\c -> toOpaque . f c . fromOpaque) (toOpaque x) s
foldr_js :: (Char -> Opaque a -> Opaque a)
-> Opaque a
-> JSString
-> IO (Opaque a)
foldr_js = ffi "(function(f,x,s){\
for(var i = s.length1; i >= 0;
x = f(s.charCodeAt(i),x);\
}\
return x;})"
#else
{-# INLINE d2c #-}
d2c :: Char -> Char
d2c = id
_jss_singleton :: Char -> IO JSString
_jss_singleton c = return $ toJSStr [c]
_jss_cons :: Char -> JSString -> IO JSString
_jss_cons c s = return $ toJSStr (c : fromJSStr s)
_jss_snoc :: JSString -> Char -> IO JSString
_jss_snoc s c = return $ toJSStr (fromJSStr s ++ [c])
_jss_append :: JSString -> JSString -> IO JSString
_jss_append a b = return $ catJSStr "" [a, b]
_jss_len :: JSString -> IO Int
_jss_len s = return $ Data.List.length $ fromJSStr s
_jss_index :: JSString -> Int -> IO Char
_jss_index s n = return $ fromJSStr s !! n
_jss_substr :: JSString -> Int -> IO JSString
_jss_substr s n = return $ toJSStr $ Data.List.drop n $ fromJSStr s
_jss_take :: Int -> JSString -> IO JSString
_jss_take n = return . toJSStr . Data.List.take n . fromJSStr
_jss_map :: (Char -> Char) -> JSString -> JSString
_jss_map f = toJSStr . Data.List.map f . fromJSStr
_jss_cmap :: (Char -> JSString) -> JSString -> JSString
_jss_cmap f =
toJSStr . Data.List.concat . Data.List.map (fromJSStr . f) . fromJSStr
_jss_rev :: JSString -> IO JSString
_jss_rev = return . toJSStr . Data.List.reverse . fromJSStr
_jss_foldl :: (a -> Char -> a) -> a -> JSString -> a
_jss_foldl f x = Data.List.foldl' f x . fromJSStr
_jss_foldr :: (Char -> a -> a) -> a -> JSString -> a
_jss_foldr f x = Data.List.foldr f x . fromJSStr
_jss_re_compile :: JSString -> JSString -> IO RegEx
_jss_re_compile _ _ =
error "Regular expressions are only supported clientside!"
_jss_re_match :: JSString -> RegEx -> IO Bool
_jss_re_match _ _ =
error "Regular expressions are only supported clientside!"
_jss_re_replace :: JSString -> RegEx -> JSString -> IO JSString
_jss_re_replace _ _ _ =
error "Regular expressions are only supported clientside!"
_jss_re_find :: RegEx -> JSString -> IO [JSString]
_jss_re_find _ _ =
error "Regular expressions are only supported clientside!"
#endif
-- | A regular expression. May be used to match and replace JSStrings.
newtype RegEx = RegEx JSAny
deriving (ToAny, FromAny)
instance IsString RegEx where
fromString s = veryUnsafePerformIO $ _jss_re_compile (fromString s) ""
-- | O(1) The empty JSString.
empty :: JSString
empty = ""
-- | O(1) JSString consisting of a single character.
singleton :: Char -> JSString
singleton = veryUnsafePerformIO . _jss_singleton
-- | O(n) Convert a list of Char into a JSString.
pack :: [Char] -> JSString
pack = toJSStr
-- | O(n) Convert a JSString to a list of Char.
unpack :: JSString -> [Char]
unpack = fromJSStr
infixr 5 `cons`
-- | O(n) Prepend a character to a JSString.
cons :: Char -> JSString -> JSString
cons c s = veryUnsafePerformIO $ _jss_cons c s
infixl 5 `snoc`
-- | O(n) Append a character to a JSString.
snoc :: JSString -> Char -> JSString
snoc s c = veryUnsafePerformIO $ _jss_snoc s c
-- | O(n) Append two JSStrings.
append :: JSString -> JSString -> JSString
append a b = veryUnsafePerformIO $ _jss_append a b
-- | O(1) Extract the first element of a non-empty JSString.
head :: JSString -> Char
head s =
#ifdef __HASTE__
case veryUnsafePerformIO $ _jss_index s 0 of
c | isNaN c -> error "Haste.JSString.head: empty JSString"
| otherwise -> d2c c -- Double/Int/Char share representation.
#else
Data.List.head $ fromJSStr s
#endif
-- | O(1) Extract the last element of a non-empty JSString.
last :: JSString -> Char
last s =
case veryUnsafePerformIO $ _jss_len s of
0 -> error "Haste.JSString.head: empty JSString"
n -> d2c (veryUnsafePerformIO $ _jss_index s (n-1))
-- | O(n) All elements but the first of a JSString. Returns an empty JSString
-- if the given JSString is empty.
tail :: JSString -> JSString
tail s = veryUnsafePerformIO $ _jss_substr s 1
-- | O(n) Drop 'n' elements from the given JSString.
drop :: Int -> JSString -> JSString
drop n s = veryUnsafePerformIO $ _jss_substr s (max 0 n)
-- | O(n) Take 'n' elements from the given JSString.
take :: Int -> JSString -> JSString
take n s = veryUnsafePerformIO $ _jss_take n s
-- | O(n) All elements but the last of a JSString. Returns an empty JSString
-- if the given JSString is empty.
init :: JSString -> JSString
init s = veryUnsafePerformIO $ _jss_take (veryUnsafePerformIO (_jss_len s)-1) s
-- | O(1) Test whether a JSString is empty.
null :: JSString -> Bool
null s = veryUnsafePerformIO (_jss_len s) == 0
-- | O(1) Get the length of a JSString as an Int.
length :: JSString -> Int
length = veryUnsafePerformIO . _jss_len
-- | O(n) Map a function over the given JSString.
map :: (Char -> Char) -> JSString -> JSString
map f s = _jss_map f s
-- | O(n) reverse a JSString.
reverse :: JSString -> JSString
reverse = veryUnsafePerformIO . _jss_rev
-- | O(n) Join a list of JSStrings, with a specified separator. Equivalent to
-- 'String.join'.
intercalate :: JSString -> [JSString] -> JSString
intercalate = catJSStr
-- | O(n) Left fold over a JSString.
foldl' :: (ToAny a, FromAny a) => (a -> Char -> a) -> a -> JSString -> a
foldl' = _jss_foldl
-- | O(n) Right fold over a JSString.
foldr :: (ToAny a, FromAny a) => (Char -> a -> a) -> a -> JSString -> a
foldr = _jss_foldr
-- | O(n) Concatenate a list of JSStrings.
concat :: [JSString] -> JSString
concat = catJSStr ""
concatMap :: (Char -> JSString) -> JSString -> JSString
concatMap = _jss_cmap
any :: (Char -> Bool) -> JSString -> Bool
any p = Haste.JSString.foldl' (\a x -> a || p x) False
all :: (Char -> Bool) -> JSString -> Bool
all p = Haste.JSString.foldl' (\a x -> a && p x) False
replicate :: Int -> Char -> JSString
replicate n c = Haste.JSString.pack $ Data.List.replicate n c
splitAt :: Int -> JSString -> (JSString, JSString)
splitAt n s = (Haste.JSString.take n s, Haste.JSString.drop n s)
matches :: JSString -> RegEx -> Bool
matches s re = veryUnsafePerformIO $ _jss_re_match s re
match :: RegEx -> JSString -> [JSString]
match re s = veryUnsafePerformIO $ _jss_re_find re s
regex :: JSString
-> JSString
-> RegEx
regex re flags = veryUnsafePerformIO $ _jss_re_compile re flags
replace :: JSString
-> RegEx
-> JSString
-> JSString
replace s re rep = veryUnsafePerformIO $ _jss_re_replace s re rep