1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
-- Module : Data.Text.Internal
-- Copyright : (c) 2008, 2009 Tom Harper,
-- (c) 2009, 2010 Bryan O'Sullivan,
-- (c) 2009 Duncan Coutts
--
-- License : BSD-style
-- Maintainer : bos@serpentine.com
-- Stability : experimental
-- Portability : GHC
--
-- A module containing private 'Text' internals. This exposes the
-- 'Text' representation and low level construction functions.
-- Modules which extend the 'Text' system may need to use this module.
--
-- You should not use this module unless you are determined to monkey
-- with the internals, as the functions here do just about nothing to
-- preserve data invariants. You have been warned!
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
#include "MachDeps.h"
#endif
module Data.Text.Internal
(
-- * Types
-- $internals
Text(..)
-- * Construction
, text
, textP
-- * Safety
, safe
-- * Code that must be here for accessibility
, empty
, empty_
-- * Utilities
, firstf
-- * Checked multiplication
, mul
, mul32
, mul64
-- * Debugging
, showText
) where
#if defined(ASSERTS)
import Control.Exception (assert)
#endif
import Data.Bits
import Data.Int (Int32, Int64)
import Data.Text.Internal.Unsafe.Char (ord)
import Data.Typeable (Typeable)
import qualified Data.Text.Array as A
-- | A space efficient, packed, unboxed Unicode text type.
data Text = Text
{-# UNPACK #-} !A.Array -- payload (Word16 elements)
{-# UNPACK #-} !Int -- offset (units of Word16, not Char)
{-# UNPACK #-} !Int -- length (units of Word16, not Char)
deriving (Typeable)
-- | Smart constructor.
text_ :: A.Array -> Int -> Int -> Text
text_ arr off len =
#if defined(ASSERTS)
let c = A.unsafeIndex arr off
alen = A.length arr
in assert (len >= 0) .
assert (off >= 0) .
assert (alen == 0 || len == 0 || off < alen) .
assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $
#endif
Text arr off len
{-# INLINE text_ #-}
-- | /O(1)/ The empty 'Text'.
empty :: Text
empty = Text A.empty 0 0
{-# INLINE [1] empty #-}
-- | A non-inlined version of 'empty'.
empty_ :: Text
empty_ = Text A.empty 0 0
{-# NOINLINE empty_ #-}
-- | Construct a 'Text' without invisibly pinning its byte array in
-- memory if its length has dwindled to zero.
text :: A.Array -> Int -> Int -> Text
text arr off len | len == 0 = empty
| otherwise = text_ arr off len
{-# INLINE text #-}
textP :: A.Array -> Int -> Int -> Text
{-# DEPRECATED textP "Use text instead" #-}
textP = text
-- | A useful 'show'-like function for debugging purposes.
showText :: Text -> String
showText (Text arr off len) =
"Text " ++ show (A.toList arr off len) ++ ' ' :
show off ++ ' ' : show len
-- | Map a 'Char' to a 'Text'-safe value.
--
-- UTF-16 surrogate code points are not included in the set of Unicode
-- scalar values, but are unfortunately admitted as valid 'Char'
-- values by Haskell. They cannot be represented in a 'Text'. This
-- function remaps those code points to the Unicode replacement
-- character (U+FFFD, \'�\'), and leaves other code points
-- unchanged.
safe :: Char -> Char
safe c
| ord c .&. 0x1ff800 /= 0xd800 = c
| otherwise = '\xfffd'
{-# INLINE [0] safe #-}
-- | Apply a function to the first element of an optional pair.
firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
firstf f (Just (a, b)) = Just (f a, b)
firstf _ Nothing = Nothing
-- | Checked multiplication. Calls 'error' if the result would
-- overflow.
mul :: Int -> Int -> Int
#if WORD_SIZE_IN_BITS == 64
mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b
#else
mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b
#endif
{-# INLINE mul #-}
infixl 7 `mul`
-- | Checked multiplication. Calls 'error' if the result would
-- overflow.
mul64 :: Int64 -> Int64 -> Int64
mul64 a b
| a >= 0 && b >= 0 = mul64_ a b
| a >= 0 = -mul64_ a (-b)
| b >= 0 = -mul64_ (-a) b
| otherwise = mul64_ (-a) (-b)
{-# INLINE mul64 #-}
infixl 7 `mul64`
mul64_ :: Int64 -> Int64 -> Int64
mul64_ a b
| ahi > 0 && bhi > 0 = error "overflow"
| top > 0x7fffffff = error "overflow"
| total < 0 = error "overflow"
| otherwise = total
where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)
(# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)
top = ahi * blo + alo * bhi
total = (top `shiftL` 32) + alo * blo
{-# INLINE mul64_ #-}
-- | Checked multiplication. Calls 'error' if the result would
-- overflow.
mul32 :: Int32 -> Int32 -> Int32
mul32 a b = case fromIntegral a * fromIntegral b of
ab | ab < min32 || ab > max32 -> error "overflow"
| otherwise -> fromIntegral ab
where min32 = -0x80000000 :: Int64
max32 = 0x7fffffff
{-# INLINE mul32 #-}
infixl 7 `mul32`
-- $internals
--
-- Internally, the 'Text' type is represented as an array of 'Word16'
-- UTF-16 code units. The offset and length fields in the constructor
-- are in these units, /not/ units of 'Char'.
--
-- Invariants that all functions must maintain:
--
-- * Since the 'Text' type uses UTF-16 internally, it cannot represent
-- characters in the reserved surrogate code point range U+D800 to
-- U+DFFF. To maintain this invariant, the 'safe' function maps
-- 'Char' values in this range to the replacement character (U+FFFD,
-- \'�\').
--
-- * A leading (or \"high\") surrogate code unit (0xD800–0xDBFF) must
-- always be followed by a trailing (or \"low\") surrogate code unit
-- (0xDC00-0xDFFF). A trailing surrogate code unit must always be
-- preceded by a leading surrogate code unit.
|
