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