git.iko.soy/text
on ryan-jsstring-inline help sign in
text/Data/Text/Internal.hs
111 lines 3.6 kB history raw
1{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples, MagicHash,
2 BangPatterns, ForeignFunctionInterface, JavaScriptFFI, GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes,
4 GHCForeignImportPrim, MagicHash, FlexibleInstances #-}
5module Data.Text.Internal
6 ( module Data.Text.Internal
7 , JSS.safe
8 , JSS.firstf
9 ) where
11import Data.String (IsString(..))
12import Data.Coerce
13import Data.Data
14import Data.Maybe
15import Data.Binary
16import Control.DeepSeq
17import Data.Semigroup
18import Data.Char
19import qualified Data.JSString as JSS
20import qualified Data.JSString.Internal as JSSS
21import qualified Data.JSString.Internal.Type as JSS
22import Data.JSString hiding (empty)
23import qualified Data.Text.Array as A
25import Data.Bits
26import Data.Int (Int32, Int64)
27-- import Data.Text.Internal.Unsafe.Char (ord)
28import Data.Typeable (Typeable)
29import GHC.Exts (ByteArray#, Char(..), ord#, andI#, (/=#), isTrue#, (==#), Int(..), Int#, isTrue#)
30-- import qualified Data.Text.Array as A
31import GHCJS.Marshal.Pure
32import GHCJS.Marshal
33import qualified GHC.CString as GHC
36newtype Text = Text JSString
37 deriving (PToJSVal, PFromJSVal, FromJSVal, ToJSVal)
39instance Show Text where
40 showsPrec p (Text jsstring) r = showsPrec p jsstring r
42empty :: Text
43empty = Text JSS.empty
44{-# INLINE [1] empty #-}
46empty_ :: Text
47empty_ = Text JSS.empty
48{-# NOINLINE empty_ #-}
50foreign import javascript unsafe
51 "String.fromCharCode.apply(null, $1['u8'])"
52 js_decodeBytes :: ByteArray# -> JSString
54foreign import javascript unsafe
55 "h$textToString"
56 js_textToString :: ByteArray# -> Int# -> Int# -> JSString
58-- | Construct a 'Text' without invisibly pinning its byte array in
59-- memory if its length has dwindled to zero.
60text :: A.Array -> Int -> Int -> Text
61-- text arr off len | len == 0 = empty
62-- | otherwise = text_ arr off len
63text (A.Array ba) (I# off#) (I# len#) | isTrue# (len# ==# 0#) = empty
64 | otherwise = Text $ js_textToString ba off# len#
66-- | Checked multiplication. Calls 'error' if the result would
67-- overflow.
68mul :: Int -> Int -> Int
69#if WORD_SIZE_IN_BITS == 64
70mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b
71#else
72mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b
73#endif
74{-# INLINE mul #-}
75infixl 7 `mul`
77-- | Checked multiplication. Calls 'error' if the result would
78-- overflow.
79mul64 :: Int64 -> Int64 -> Int64
80mul64 a b
81 | a >= 0 && b >= 0 = mul64_ a b
82 | a >= 0 = -mul64_ a (-b)
83 | b >= 0 = -mul64_ (-a) b
84 | otherwise = mul64_ (-a) (-b)
85{-# INLINE mul64 #-}
86infixl 7 `mul64`
88mul64_ :: Int64 -> Int64 -> Int64
89mul64_ a b
90 | ahi > 0 && bhi > 0 = error "overflow"
91 | top > 0x7fffffff = error "overflow"
92 | total < 0 = error "overflow"
93 | otherwise = total
94 where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)
95 (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)
96 top = ahi * blo + alo * bhi
97 total = (top `shiftL` 32) + alo * blo
98{-# INLINE mul64_ #-}
100-- | Checked multiplication. Calls 'error' if the result would
101-- overflow.
102mul32 :: Int32 -> Int32 -> Int32
103mul32 a b = case fromIntegral a * fromIntegral b of
104 ab | ab < min32 || ab > max32 -> error "overflow"
105 | otherwise -> fromIntegral ab
106 where min32 = -0x80000000 :: Int64
107 max32 = 0x7fffffff
108{-# INLINE mul32 #-}
109infixl 7 `mul32`
111--------------------------------------