@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples #-}
22{-# OPTIONS_HADDOCK not-home #-}
33
44-- |
@@ -20,6 +20,10 @@
2020-- with the internals, as the functions here do just about nothing to
2121-- preserve data invariants. You have been warned!
2222
23+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
24+#include "MachDeps.h"
25+#endif
26+
2327module Data.Text.Internal
2428 (
2529 -- * Types
@@ -34,6 +38,10 @@ module Data.Text.Internal
3438 , empty
3539 -- * Utilities
3640 , firstf
41+ -- * Checked multiplication
42+ , mul
43+ , mul32
44+ , mul64
3745 -- * Debugging
3846 , showText
3947 ) where
@@ -41,10 +49,11 @@ module Data.Text.Internal
4149#if defined(ASSERTS)
4250import Control.Exception (assert)
4351#endif
44−import Data.Bits ((.&.))
45−import qualified Data.Text.Array as A
52+import Data.Bits
53+import Data.Int (Int32, Int64)
4654import Data.Text.Internal.Unsafe.Char (ord)
4755import Data.Typeable (Typeable)
56+import qualified Data.Text.Array as A
4857
4958-- | A space efficient, packed, unboxed Unicode text type.
5059data Text = Text
@@ -108,6 +117,51 @@ firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
108117firstf f (Just (a, b)) = Just (f a, b)
109118firstf _ Nothing = Nothing
110119
120+-- | Checked multiplication. Calls 'error' if the result would
121+-- overflow.
122+mul :: Int -> Int -> Int
123+#if WORD_SIZE_IN_BITS == 64
124+mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b
125+#else
126+mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b
127+#endif
128+{-# INLINE mul #-}
129+infixl 7 `mul`
130+
131+-- | Checked multiplication. Calls 'error' if the result would
132+-- overflow.
133+mul64 :: Int64 -> Int64 -> Int64
134+mul64 a b
135+ | a >= 0 && b >= 0 = mul64_ a b
136+ | a >= 0 = -mul64_ a (-b)
137+ | b >= 0 = -mul64_ (-a) b
138+ | otherwise = mul64_ (-a) (-b)
139+{-# INLINE mul64 #-}
140+infixl 7 `mul64`
141+
142+mul64_ :: Int64 -> Int64 -> Int64
143+mul64_ a b
144+ | ahi > 0 && bhi > 0 = error "overflow"
145+ | top > 0x7fffffff = error "overflow"
146+ | total < 0 = error "overflow"
147+ | otherwise = total
148+ where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)
149+ (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)
150+ top = ahi * blo + alo * bhi
151+ total = (top `shiftL` 32) + alo * blo
152+{-# INLINE mul64_ #-}
153+
154+-- | Checked multiplication. Calls 'error' if the result would
155+-- overflow.
156+mul32 :: Int32 -> Int32 -> Int32
157+mul32 a b = case fromIntegral a * fromIntegral b of
158+ ab | ab < min32 || ab > max32 -> error "overflow"
159+ | otherwise -> fromIntegral ab
160+ where min32 = -0x80000000 :: Int64
161+ max32 = 0x7fffffff
162+{-# INLINE mul32 #-}
163+infixl 7 `mul32`
164+
111165-- $internals
112166--
113167-- Internally, the 'Text' type is represented as an array of 'Word16'