@@ -0,0 +1,237 @@
1+{-# LANGUAGE CPP, ExistentialQuantification, MagicHash, Rank2Types,
2+ ScopedTypeVariables, UnboxedTuples #-}
3+-- |
4+-- Module : Data.Text.Array
5+-- Copyright : (c) Bryan O'Sullivan 2009
6+--
7+-- License : BSD-style
8+-- Maintainer : bos@serpentine.com,
9+-- Stability : experimental
10+-- Portability : portable
11+--
12+-- Packed, unboxed, heap-resident arrays. Suitable for performance
13+-- critical use, both in terms of large data quantities and high
14+-- speed.
15+--
16+-- This module is intended to be imported @qualified@, to avoid name
17+-- clashes with "Prelude" functions, e.g.
18+--
19+-- > import qualified Data.Text.Array as A
20+--
21+-- The names in this module resemble those in the 'Data.Array' family
22+-- of modules, but are shorter due to the assumption of qualifid
23+-- naming.
24+module Data.Text.Array
25+ (
26+ -- * Types
27+ IArray(..)
28+ , Elt(..)
29+ , Array
30+ , MArray
31+
32+ -- * Functions
33+ , empty
34+ , new
35+ , unsafeNew
36+ , unsafeFreeze
37+ , run
38+ ) where
39+
40+#if defined(__GLASGOW_HASKELL__)
41+#include "MachDeps.h"
42+
43+import GHC.Base (ByteArray#, MutableByteArray#, indexWord16Array#,
44+ newByteArray#, readWord16Array#, unsafeCoerce#,
45+ writeWord16Array#, (+#), (*#))
46+import GHC.Prim (Int#)
47+import GHC.ST (ST(..), runST)
48+import GHC.Types (Int(..))
49+import GHC.Word (Word16(..))
50+
51+#elif defined(__HUGS__)
52+
53+import Hugs.ByteArray (ByteArray, MutableByteArray, readByteArray,
54+ newMutableByteArray, readMutableByteArray,
55+ unsafeFreezeMutableByteArray, writeMutableByteArray)
56+import Foreign.Storable (Storable, sizeOf)
57+import Hugs.ST (ST(..), runST)
58+
59+#else
60+# error not implemented for this compiler
61+#endif
62+
63+import Data.Typeable
64+import Data.Word (Word16)
65+import Prelude hiding (length, read)
66+
67+#include "Typeable.h"
68+
69+-- | Immutable array type.
70+data Array e = Array
71+ {-# UNPACK #-} !Int -- length (in units of e, not bytes)
72+#if defined(__GLASGOW_HASKELL__)
73+ ByteArray#
74+#elif defined(__HUGS__)
75+ !ByteArray
76+#endif
77+
78+INSTANCE_TYPEABLE1(Array,arrayTc,"Array")
79+
80+-- | Mutable array type, for use in the ST monad.
81+data MArray s e = MArray
82+ {-# UNPACK #-} !Int -- length (in units of e, not bytes)
83+#if defined(__GLASGOW_HASKELL__)
84+ (MutableByteArray# s)
85+#elif defined(__HUGS__)
86+ !(MutableByteArray s)
87+#endif
88+
89+INSTANCE_TYPEABLE2(MArray,mArrayTc,"MArray")
90+
91+-- | Operations supported by all arrays.
92+class IArray a where
93+ -- | Return the length of an array.
94+ length :: a -> Int
95+
96+instance IArray (Array e) where
97+ length (Array len _ba) = len
98+ {-# INLINE length #-}
99+
100+instance IArray (MArray s e) where
101+ length (MArray len _ba) = len
102+ {-# INLINE length #-}
103+
104+check :: IArray a => String -> a -> Int -> (a -> Int -> b) -> b
105+check func ary i f
106+ | i >= 0 && i < length ary = f ary i
107+ | otherwise = error ("Data.Array.Flat." ++ func ++ ": index out of bounds")
108+{-# INLINE check #-}
109+
110+-- | Operations supported by all elements that can be stored in
111+-- arrays.
112+class Elt e where
113+ -- | Indicate how many bytes would be used for an array of the
114+ -- given size.
115+ bytesInArray :: Int -> e -> Int
116+ -- | Unchecked read of an immutable array. May return garbage or
117+ -- crash on an out-of-bounds access.
118+ unsafeIndex :: Array e -> Int -> e
119+ -- | Unchecked read of a mutable array. May return garbage or
120+ -- crash on an out-of-bounds access.
121+ unsafeRead :: MArray s e -> Int -> ST s e
122+ -- | Unchecked write of a mutable array. May return garbage or
123+ -- crash on an out-of-bounds access.
124+ unsafeWrite :: MArray s e -> Int -> e -> ST s ()
125+
126+ -- | Read an immutable array. An invalid index results in a
127+ -- runtime error.
128+ index :: Array e -> Int -> e
129+ index ary i = check "index" ary i unsafeIndex
130+ {-# INLINE index #-}
131+
132+ -- | Read a mutable array. An invalid index results in a runtime
133+ -- error.
134+ read :: Array e -> Int -> ST s e
135+ read ary i = check "read" ary i read
136+ {-# INLINE read #-}
137+
138+ -- | Write a mutable array. An invalid index results in a runtime
139+ -- error.
140+ write :: Array e -> Int -> ST s e
141+ write ary i = check "write" ary i write
142+ {-# INLINE write #-}
143+
144+-- | Freeze a mutable array. Do not mutate the 'MArray' afterwards!
145+unsafeFreeze :: MArray s e -> ST s (Array e)
146+
147+#if defined(__GLASGOW_HASKELL__)
148+
149+wORD16_SCALE :: Int# -> Int#
150+wORD16_SCALE n# = scale# *# n# where I# scale# = SIZEOF_WORD16
151+
152+-- | Create an uninitialized mutable array.
153+unsafeNew :: forall s e. Elt e => Int -> ST s (MArray s e)
154+unsafeNew n = ST $ \s1# ->
155+ case bytesInArray n (undefined :: e) of
156+ (I# len#) -> case newByteArray# len# s1# of
157+ (# s2#, marr# #) -> (# s2#, MArray n marr# #)
158+{-# INLINE unsafeNew #-}
159+
160+unsafeFreeze (MArray len mba#) = ST $ \s# ->
161+ (# s#, Array len (unsafeCoerce# mba#) #)
162+{-# INLINE unsafeFreeze #-}
163+
164+-- | Create a mutable array, with its elements initialized with the
165+-- given value.
166+new :: forall s e. Elt e => Int -> e -> ST s (MArray s e)
167+
168+#elif defined(__HUGS__)
169+
170+unsafeIndexArray :: Storable e => Array e -> Int -> e
171+unsafeIndexArray (Array off _len arr) i = readByteArray arr (off + i)
172+
173+unsafeReadMArray :: Storable e => MArray s e -> Int -> ST s e
174+unsafeReadMArray (MArray _len marr) = readMutableByteArray marr
175+
176+unsafeWriteMArray :: Storable e => MArray s e -> Int -> e -> ST s ()
177+unsafeWriteMArray (MArray _len marr) = writeMutableByteArray marr
178+
179+-- | Create an uninitialized mutable array.
180+unsafeNew :: (Storable e) => Int -> ST s (MArray s e)
181+unsafeNew n = new undefined
182+ where new :: (Storable e) => e -> ST s (MArray s e)
183+ new unused = do
184+ marr <- newMutableByteArray (n * sizeOf unused)
185+ return (MArray n marr)
186+
187+unsafeFreeze (MArray len mba) = do
188+ ba <- unsafeFreezeMutableByteArray mba
189+ return (Array 0 len ba)
190+
191+-- | Create a mutable array, with its elements initialized with the
192+-- given value.
193+new :: (Storable e) => Int -> e -> ST s (MArray s e)
194+#endif
195+
196+new len initVal = do
197+ marr <- unsafeNew len
198+ sequence_ [unsafeWrite marr i initVal | i <- [0..len-1]]
199+ return marr
200+
201+instance Elt Word16 where
202+#if defined(__GLASGOW_HASKELL__)
203+
204+ bytesInArray (I# i#) _ = I# (wORD16_SCALE i#)
205+ {-# INLINE bytesInArray #-}
206+
207+ unsafeIndex (Array _len ba#) (I# i#) =
208+ case indexWord16Array# ba# i# of r# -> (W16# r#)
209+ {-# INLINE unsafeIndex #-}
210+
211+ unsafeRead (MArray _len mba#) (I# i#) = ST $ \s# ->
212+ case readWord16Array# mba# i# s# of
213+ (# s2#, r# #) -> (# s2#, W16# r# #)
214+ {-# INLINE unsafeRead #-}
215+
216+ unsafeWrite (MArray _len marr#) (I# i#) (W16# e#) = ST $ \s1# ->
217+ case writeWord16Array# marr# i# e# s1# of
218+ s2# -> (# s2#, () #)
219+ {-# INLINE unsafeWrite #-}
220+
221+#elif defined(__HUGS__)
222+
223+ bytesInArray n w = sizeOf w * n
224+ unsafeIndex = unsafeIndexArray
225+ unsafeRead = unsafeReadMArray
226+ unsafeWrite = unsafeWriteMArray
227+
228+#endif
229+
230+-- | An empty immutable array.
231+empty :: Elt e => Array e
232+empty = runST (unsafeNew 0 >>= unsafeFreeze)
233+
234+-- | Run an action in the ST monad and return an immutable array of
235+-- its result.
236+run :: Elt e => (forall s. ST s (MArray s e)) -> Array e
237+run k = runST (k >>= unsafeFreeze)