From: Ian Lynagh Date: Wed, 1 Aug 2007 23:55:42 +0000 (+0000) Subject: Data.Array* and Data.PackedString have now moved to their own packages X-Git-Tag: 2007-09-13~23 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2b3b83d94a6ed3969cc01dc9ce7b1994f6b9e9cd;p=ghc-base.git Data.Array* and Data.PackedString have now moved to their own packages --- diff --git a/Data/Array.hs b/Data/Array.hs deleted file mode 100644 index 09c4f65..0000000 --- a/Data/Array.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# OPTIONS_GHC -fno-implicit-prelude #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Array --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- Basic non-strict arrays. --- --- /Note:/ The "Data.Array.IArray" module provides more general interface --- to immutable arrays: it defines operations with the same names as --- those defined below, but with more general types, and also defines --- 'Array' instances of the relevant classes. To use that more general --- interface, import "Data.Array.IArray" but not "Data.Array". ------------------------------------------------------------------------------ - -module Data.Array - - ( - -- * Immutable non-strict arrays - -- $intro - module Data.Ix -- export all of Ix - , Array -- Array type is abstract - - -- * Array construction - , array -- :: (Ix a) => (a,a) -> [(a,b)] -> Array a b - , listArray -- :: (Ix a) => (a,a) -> [b] -> Array a b - , accumArray -- :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b - -- * Accessing arrays - , (!) -- :: (Ix a) => Array a b -> a -> b - , bounds -- :: (Ix a) => Array a b -> (a,a) - , indices -- :: (Ix a) => Array a b -> [a] - , elems -- :: (Ix a) => Array a b -> [b] - , assocs -- :: (Ix a) => Array a b -> [(a,b)] - -- * Incremental array updates - , (//) -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b - , accum -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b - -- * Derived arrays - , ixmap -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b - - -- Array instances: - -- - -- Ix a => Functor (Array a) - -- (Ix a, Eq b) => Eq (Array a b) - -- (Ix a, Ord b) => Ord (Array a b) - -- (Ix a, Show a, Show b) => Show (Array a b) - -- (Ix a, Read a, Read b) => Read (Array a b) - -- - - -- Implementation checked wrt. Haskell 98 lib report, 1/99. - - ) where - -import Data.Ix - -#ifdef __GLASGOW_HASKELL__ -import GHC.Arr -- Most of the hard work is done here -import Data.Generics.Basics -- To provide a Data instance -import Data.Generics.Instances -- To provide a Data instance -import GHC.Err ( error ) -- Needed for Data instance -#endif - -#ifdef __HUGS__ -import Hugs.Array -#endif - -#ifdef __NHC__ -import Array -- Haskell'98 arrays -#endif - -import Data.Typeable - -{- $intro -Haskell provides indexable /arrays/, which may be thought of as functions -whose domains are isomorphic to contiguous subsets of the integers. -Functions restricted in this way can be implemented efficiently; -in particular, a programmer may reasonably expect rapid access to -the components. To ensure the possibility of such an implementation, -arrays are treated as data, not as general functions. - -Since most array functions involve the class 'Ix', this module is exported -from "Data.Array" so that modules need not import both "Data.Array" and -"Data.Ix". --} diff --git a/Data/Array/Base.hs b/Data/Array/Base.hs deleted file mode 100644 index 0f1c389..0000000 --- a/Data/Array/Base.hs +++ /dev/null @@ -1,1749 +0,0 @@ -{-# OPTIONS_GHC -fno-bang-patterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Array.Base --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (MPTCs, uses Control.Monad.ST) --- --- Basis for IArray and MArray. Not intended for external consumption; --- use IArray or MArray instead. --- ------------------------------------------------------------------------------ - --- #hide -module Data.Array.Base where - -import Prelude - -import Control.Monad.ST.Lazy ( strictToLazyST ) -import qualified Control.Monad.ST.Lazy as Lazy (ST) -import Data.Ix ( Ix, range, index, rangeSize ) -import Data.Int -import Data.Word -import Foreign.C.Types -import Foreign.Ptr -import Foreign.StablePtr - -#ifdef __GLASGOW_HASKELL__ -import GHC.Arr ( STArray, unsafeIndex ) -import qualified GHC.Arr as Arr -import qualified GHC.Arr as ArrST -import GHC.ST ( ST(..), runST ) -import GHC.Base -import GHC.Word ( Word(..) ) -import GHC.Ptr ( Ptr(..), FunPtr(..), nullPtr, nullFunPtr ) -import GHC.Float ( Float(..), Double(..) ) -import GHC.Stable ( StablePtr(..) ) -import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) -import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) ) -import GHC.IOBase ( IO(..) ) -#endif - -#ifdef __HUGS__ -import Data.Bits -import Foreign.Storable -import qualified Hugs.Array as Arr -import qualified Hugs.ST as ArrST -import Hugs.Array ( unsafeIndex ) -import Hugs.ST ( STArray, ST(..), runST ) -import Hugs.ByteArray -#endif - -import Data.Typeable -#include "Typeable.h" - -#include "MachDeps.h" - ------------------------------------------------------------------------------ --- Class of immutable arrays - -{- | Class of immutable array types. - -An array type has the form @(a i e)@ where @a@ is the array type -constructor (kind @* -> * -> *@), @i@ is the index type (a member of -the class 'Ix'), and @e@ is the element type. The @IArray@ class is -parameterised over both @a@ and @e@, so that instances specialised to -certain element types can be defined. --} -class IArray a e where - -- | Extracts the bounds of an immutable array - bounds :: Ix i => a i e -> (i,i) - unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> a i e - unsafeAt :: Ix i => a i e -> Int -> e - unsafeReplace :: Ix i => a i e -> [(Int, e)] -> a i e - unsafeAccum :: Ix i => (e -> e' -> e) -> a i e -> [(Int, e')] -> a i e - unsafeAccumArray :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> a i e - - unsafeReplace arr ies = runST (unsafeReplaceST arr ies >>= unsafeFreeze) - unsafeAccum f arr ies = runST (unsafeAccumST f arr ies >>= unsafeFreeze) - unsafeAccumArray f e lu ies = runST (unsafeAccumArrayST f e lu ies >>= unsafeFreeze) - -{-# INLINE unsafeReplaceST #-} -unsafeReplaceST :: (IArray a e, Ix i) => a i e -> [(Int, e)] -> ST s (STArray s i e) -unsafeReplaceST arr ies = do - marr <- thaw arr - sequence_ [unsafeWrite marr i e | (i, e) <- ies] - return marr - -{-# INLINE unsafeAccumST #-} -unsafeAccumST :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(Int, e')] -> ST s (STArray s i e) -unsafeAccumST f arr ies = do - marr <- thaw arr - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] - return marr - -{-# INLINE unsafeAccumArrayST #-} -unsafeAccumArrayST :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (STArray s i e) -unsafeAccumArrayST f e (l,u) ies = do - marr <- newArray (l,u) e - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] - return marr - - -{-# INLINE array #-} - -{-| Constructs an immutable array from a pair of bounds and a list of -initial associations. - -The bounds are specified as a pair of the lowest and highest bounds in -the array respectively. For example, a one-origin vector of length 10 -has bounds (1,10), and a one-origin 10 by 10 matrix has bounds -((1,1),(10,10)). - -An association is a pair of the form @(i,x)@, which defines the value of -the array at index @i@ to be @x@. The array is undefined if any index -in the list is out of bounds. If any two associations in the list have -the same index, the value at that index is implementation-dependent. -(In GHC, the last value specified for that index is used. -Other implementations will also do this for unboxed arrays, but Haskell -98 requires that for 'Array' the value at such indices is bottom.) - -Because the indices must be checked for these errors, 'array' is -strict in the bounds argument and in the indices of the association -list. Whether @array@ is strict or non-strict in the elements depends -on the array type: 'Data.Array.Array' is a non-strict array type, but -all of the 'Data.Array.Unboxed.UArray' arrays are strict. Thus in a -non-strict array, recurrences such as the following are possible: - -> a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i \<- [2..100]]) - -Not every index within the bounds of the array need appear in the -association list, but the values associated with indices that do not -appear will be undefined. - -If, in any dimension, the lower bound is greater than the upper bound, -then the array is legal, but empty. Indexing an empty array always -gives an array-bounds error, but 'bounds' still yields the bounds with -which the array was constructed. --} -array :: (IArray a e, Ix i) - => (i,i) -- ^ bounds of the array: (lowest,highest) - -> [(i, e)] -- ^ list of associations - -> a i e -array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies] - --- Since unsafeFreeze is not guaranteed to be only a cast, we will --- use unsafeArray and zip instead of a specialized loop to implement --- listArray, unlike Array.listArray, even though it generates some --- unnecessary heap allocation. Will use the loop only when we have --- fast unsafeFreeze, namely for Array and UArray (well, they cover --- almost all cases). - -{-# INLINE listArray #-} - --- | Constructs an immutable array from a list of initial elements. --- The list gives the elements of the array in ascending order --- beginning with the lowest index. -listArray :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e -listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es) - -{-# INLINE listArrayST #-} -listArrayST :: Ix i => (i,i) -> [e] -> ST s (STArray s i e) -listArrayST (l,u) es = do - marr <- newArray_ (l,u) - let n = rangeSize (l,u) - let fillFromList i xs | i == n = return () - | otherwise = case xs of - [] -> return () - y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys - fillFromList 0 es - return marr - -{-# RULES -"listArray/Array" listArray = - \lu es -> runST (listArrayST lu es >>= ArrST.unsafeFreezeSTArray) - #-} - -{-# INLINE listUArrayST #-} -listUArrayST :: (MArray (STUArray s) e (ST s), Ix i) - => (i,i) -> [e] -> ST s (STUArray s i e) -listUArrayST (l,u) es = do - marr <- newArray_ (l,u) - let n = rangeSize (l,u) - let fillFromList i xs | i == n = return () - | otherwise = case xs of - [] -> return () - y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys - fillFromList 0 es - return marr - --- I don't know how to write a single rule for listUArrayST, because --- the type looks like constrained over 's', which runST doesn't --- like. In fact all MArray (STUArray s) instances are polymorphic --- wrt. 's', but runST can't know that. --- --- More precisely, we'd like to write this: --- listUArray :: (forall s. MArray (STUArray s) e (ST s), Ix i) --- => (i,i) -> [e] -> UArray i e --- listUArray lu = runST (listUArrayST lu es >>= unsafeFreezeSTUArray) --- {-# RULES listArray = listUArray --- Then we could call listUArray at any type 'e' that had a suitable --- MArray instance. But sadly we can't, because we don't have quantified --- constraints. Hence the mass of rules below. - --- I would like also to write a rule for listUArrayST (or listArray or --- whatever) applied to unpackCString#. Unfortunately unpackCString# --- calls seem to be floated out, then floated back into the middle --- of listUArrayST, so I was not able to do this. - -#ifdef __GLASGOW_HASKELL__ -type ListUArray e = forall i . Ix i => (i,i) -> [e] -> UArray i e - -{-# RULES -"listArray/UArray/Bool" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Bool -"listArray/UArray/Char" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Char -"listArray/UArray/Int" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int -"listArray/UArray/Word" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word -"listArray/UArray/Ptr" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray (Ptr a) -"listArray/UArray/FunPtr" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray (FunPtr a) -"listArray/UArray/Float" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Float -"listArray/UArray/Double" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Double -"listArray/UArray/StablePtr" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray (StablePtr a) -"listArray/UArray/Int8" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int8 -"listArray/UArray/Int16" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int16 -"listArray/UArray/Int32" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int32 -"listArray/UArray/Int64" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Int64 -"listArray/UArray/Word8" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word8 -"listArray/UArray/Word16" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word16 -"listArray/UArray/Word32" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word32 -"listArray/UArray/Word64" listArray - = (\lu es -> runST (listUArrayST lu es >>= unsafeFreezeSTUArray)) :: ListUArray Word64 - #-} -#endif - -{-# INLINE (!) #-} --- | Returns the element of an immutable array at the specified index. -(!) :: (IArray a e, Ix i) => a i e -> i -> e -arr ! i = case bounds arr of (l,u) -> unsafeAt arr (index (l,u) i) - -{-# INLINE indices #-} --- | Returns a list of all the valid indices in an array. -indices :: (IArray a e, Ix i) => a i e -> [i] -indices arr = case bounds arr of (l,u) -> range (l,u) - -{-# INLINE elems #-} --- | Returns a list of all the elements of an array, in the same order --- as their indices. -elems :: (IArray a e, Ix i) => a i e -> [e] -elems arr = case bounds arr of - (l,u) -> [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]] - -{-# INLINE assocs #-} --- | Returns the contents of an array as a list of associations. -assocs :: (IArray a e, Ix i) => a i e -> [(i, e)] -assocs arr = case bounds arr of - (l,u) -> [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)] - -{-# INLINE accumArray #-} - -{-| -Constructs an immutable array from a list of associations. Unlike -'array', the same index is allowed to occur multiple times in the list -of associations; an /accumulating function/ is used to combine the -values of elements with the same index. - -For example, given a list of values of some index type, hist produces -a histogram of the number of occurrences of each index within a -specified range: - -> hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b -> hist bnds is = accumArray (+) 0 bnds [(i, 1) | i\<-is, inRange bnds i] --} -accumArray :: (IArray a e, Ix i) - => (e -> e' -> e) -- ^ An accumulating function - -> e -- ^ A default element - -> (i,i) -- ^ The bounds of the array - -> [(i, e')] -- ^ List of associations - -> a i e -- ^ Returns: the array -accumArray f init (l,u) ies = - unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies] - -{-# INLINE (//) #-} -{-| -Takes an array and a list of pairs and returns an array identical to -the left argument except that it has been updated by the associations -in the right argument. For example, if m is a 1-origin, n by n matrix, -then @m\/\/[((i,i), 0) | i \<- [1..n]]@ is the same matrix, except with -the diagonal zeroed. - -As with the 'array' function, if any two associations in the list have -the same index, the value at that index is implementation-dependent. -(In GHC, the last value specified for that index is used. -Other implementations will also do this for unboxed arrays, but Haskell -98 requires that for 'Array' the value at such indices is bottom.) - -For most array types, this operation is O(/n/) where /n/ is the size -of the array. However, the 'Data.Array.Diff.DiffArray' type provides -this operation with complexity linear in the number of updates. --} -(//) :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e -arr // ies = case bounds arr of - (l,u) -> unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies] - -{-# INLINE accum #-} -{-| -@accum f@ takes an array and an association list and accumulates pairs -from the list into the array with the accumulating function @f@. Thus -'accumArray' can be defined using 'accum': - -> accumArray f z b = accum f (array b [(i, z) | i \<- range b]) --} -accum :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e -accum f arr ies = case bounds arr of - (l,u) -> unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies] - -{-# INLINE amap #-} --- | Returns a new array derived from the original array by applying a --- function to each of the elements. -amap :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e -amap f arr = case bounds arr of - (l,u) -> unsafeArray (l,u) [(i, f (unsafeAt arr i)) | - i <- [0 .. rangeSize (l,u) - 1]] -{-# INLINE ixmap #-} --- | Returns a new array derived from the original array by applying a --- function to each of the indices. -ixmap :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e -ixmap (l,u) f arr = - unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)] - ------------------------------------------------------------------------------ --- Normal polymorphic arrays - -instance IArray Arr.Array e where - {-# INLINE bounds #-} - bounds = Arr.bounds - {-# INLINE unsafeArray #-} - unsafeArray = Arr.unsafeArray - {-# INLINE unsafeAt #-} - unsafeAt = Arr.unsafeAt - {-# INLINE unsafeReplace #-} - unsafeReplace = Arr.unsafeReplace - {-# INLINE unsafeAccum #-} - unsafeAccum = Arr.unsafeAccum - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray = Arr.unsafeAccumArray - ------------------------------------------------------------------------------ --- Flat unboxed arrays - --- | Arrays with unboxed elements. Instances of 'IArray' are provided --- for 'UArray' with certain element types ('Int', 'Float', 'Char', --- etc.; see the 'UArray' class for a full list). --- --- A 'UArray' will generally be more efficient (in terms of both time --- and space) than the equivalent 'Data.Array.Array' with the same --- element type. However, 'UArray' is strict in its elements - so --- don\'t use 'UArray' if you require the non-strictness that --- 'Data.Array.Array' provides. --- --- Because the @IArray@ interface provides operations overloaded on --- the type of the array, it should be possible to just change the --- array type being used by a program from say @Array@ to @UArray@ to --- get the benefits of unboxed arrays (don\'t forget to import --- "Data.Array.Unboxed" instead of "Data.Array"). --- -#ifdef __GLASGOW_HASKELL__ -data UArray i e = UArray !i !i ByteArray# -#endif -#ifdef __HUGS__ -data UArray i e = UArray !i !i !ByteArray -#endif - -INSTANCE_TYPEABLE2(UArray,uArrayTc,"UArray") - -{-# INLINE unsafeArrayUArray #-} -unsafeArrayUArray :: (MArray (STUArray s) e (ST s), Ix i) - => (i,i) -> [(Int, e)] -> e -> ST s (UArray i e) -unsafeArrayUArray (l,u) ies default_elem = do - marr <- newArray (l,u) default_elem - sequence_ [unsafeWrite marr i e | (i, e) <- ies] - unsafeFreezeSTUArray marr - -#ifdef __GLASGOW_HASKELL__ -{-# INLINE unsafeFreezeSTUArray #-} -unsafeFreezeSTUArray :: STUArray s i e -> ST s (UArray i e) -unsafeFreezeSTUArray (STUArray l u marr#) = ST $ \s1# -> - case unsafeFreezeByteArray# marr# s1# of { (# s2#, arr# #) -> - (# s2#, UArray l u arr# #) } -#endif - -#ifdef __HUGS__ -unsafeFreezeSTUArray :: STUArray s i e -> ST s (UArray i e) -unsafeFreezeSTUArray (STUArray l u marr) = do - arr <- unsafeFreezeMutableByteArray marr - return (UArray l u arr) -#endif - -{-# INLINE unsafeReplaceUArray #-} -unsafeReplaceUArray :: (MArray (STUArray s) e (ST s), Ix i) - => UArray i e -> [(Int, e)] -> ST s (UArray i e) -unsafeReplaceUArray arr ies = do - marr <- thawSTUArray arr - sequence_ [unsafeWrite marr i e | (i, e) <- ies] - unsafeFreezeSTUArray marr - -{-# INLINE unsafeAccumUArray #-} -unsafeAccumUArray :: (MArray (STUArray s) e (ST s), Ix i) - => (e -> e' -> e) -> UArray i e -> [(Int, e')] -> ST s (UArray i e) -unsafeAccumUArray f arr ies = do - marr <- thawSTUArray arr - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] - unsafeFreezeSTUArray marr - -{-# INLINE unsafeAccumArrayUArray #-} -unsafeAccumArrayUArray :: (MArray (STUArray s) e (ST s), Ix i) - => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (UArray i e) -unsafeAccumArrayUArray f init (l,u) ies = do - marr <- newArray (l,u) init - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] - unsafeFreezeSTUArray marr - -{-# INLINE eqUArray #-} -eqUArray :: (IArray UArray e, Ix i, Eq e) => UArray i e -> UArray i e -> Bool -eqUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) = - if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else - l1 == l2 && u1 == u2 && - and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]] - -{-# INLINE cmpUArray #-} -cmpUArray :: (IArray UArray e, Ix i, Ord e) => UArray i e -> UArray i e -> Ordering -cmpUArray arr1 arr2 = compare (assocs arr1) (assocs arr2) - -{-# INLINE cmpIntUArray #-} -cmpIntUArray :: (IArray UArray e, Ord e) => UArray Int e -> UArray Int e -> Ordering -cmpIntUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) = - if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else - if rangeSize (l2,u2) == 0 then GT else - case compare l1 l2 of - EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1] - other -> other - where - cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of - EQ -> rest - other -> other - -{-# RULES "cmpUArray/Int" cmpUArray = cmpIntUArray #-} - ------------------------------------------------------------------------------ --- Showing IArrays - -{-# SPECIALISE - showsIArray :: (IArray UArray e, Ix i, Show i, Show e) => - Int -> UArray i e -> ShowS - #-} - -showsIArray :: (IArray a e, Ix i, Show i, Show e) => Int -> a i e -> ShowS -showsIArray p a = - showParen (p > 9) $ - showString "array " . - shows (bounds a) . - showChar ' ' . - shows (assocs a) - ------------------------------------------------------------------------------ --- Flat unboxed arrays: instances - -#ifdef __HUGS__ -unsafeAtBArray :: Storable e => UArray i e -> Int -> e -unsafeAtBArray (UArray _ _ arr) = readByteArray arr -#endif - -instance IArray UArray Bool where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies False) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = - (indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#) - `neWord#` int2Word# 0# -#endif -#ifdef __HUGS__ - unsafeAt (UArray _ _ arr) i = - testBit (readByteArray arr (bOOL_INDEX i)::BitSet) (bOOL_SUBINDEX i) -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Char where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies '\0') - {-# INLINE unsafeAt #-} -#ifdef __GLASGOW_HASKELL__ - unsafeAt (UArray _ _ arr#) (I# i#) = C# (indexWideCharArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Int where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = I# (indexIntArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Word where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = W# (indexWordArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray (Ptr a) where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullPtr) - {-# INLINE unsafeAt #-} -#ifdef __GLASGOW_HASKELL__ - unsafeAt (UArray _ _ arr#) (I# i#) = Ptr (indexAddrArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray (FunPtr a) where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullFunPtr) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = FunPtr (indexAddrArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Float where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = F# (indexFloatArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Double where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = D# (indexDoubleArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray (StablePtr a) where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies nullStablePtr) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = StablePtr (indexStablePtrArray# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - --- bogus StablePtr value for initialising a UArray of StablePtr. -#ifdef __GLASGOW_HASKELL__ -nullStablePtr = StablePtr (unsafeCoerce# 0#) -#endif -#ifdef __HUGS__ -nullStablePtr = castPtrToStablePtr nullPtr -#endif - -instance IArray UArray Int8 where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = I8# (indexInt8Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Int16 where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = I16# (indexInt16Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Int32 where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = I32# (indexInt32Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Int64 where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = I64# (indexInt64Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Word8 where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = W8# (indexWord8Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Word16 where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = W16# (indexWord16Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Word32 where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = W32# (indexWord32Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance IArray UArray Word64 where - {-# INLINE bounds #-} - bounds (UArray l u _) = (l,u) - {-# INLINE unsafeArray #-} - unsafeArray lu ies = runST (unsafeArrayUArray lu ies 0) -#ifdef __GLASGOW_HASKELL__ - {-# INLINE unsafeAt #-} - unsafeAt (UArray _ _ arr#) (I# i#) = W64# (indexWord64Array# arr# i#) -#endif -#ifdef __HUGS__ - unsafeAt = unsafeAtBArray -#endif - {-# INLINE unsafeReplace #-} - unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) - {-# INLINE unsafeAccum #-} - unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) - {-# INLINE unsafeAccumArray #-} - unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) - -instance (Ix ix, Eq e, IArray UArray e) => Eq (UArray ix e) where - (==) = eqUArray - -instance (Ix ix, Ord e, IArray UArray e) => Ord (UArray ix e) where - compare = cmpUArray - -instance (Ix ix, Show ix, Show e, IArray UArray e) => Show (UArray ix e) where - showsPrec = showsIArray - ------------------------------------------------------------------------------ --- Mutable arrays - -{-# NOINLINE arrEleBottom #-} -arrEleBottom :: a -arrEleBottom = error "MArray: undefined array element" - -{-| Class of mutable array types. - -An array type has the form @(a i e)@ where @a@ is the array type -constructor (kind @* -> * -> *@), @i@ is the index type (a member of -the class 'Ix'), and @e@ is the element type. - -The @MArray@ class is parameterised over both @a@ and @e@ (so that -instances specialised to certain element types can be defined, in the -same way as for 'IArray'), and also over the type of the monad, @m@, -in which the mutable array will be manipulated. --} -class (Monad m) => MArray a e m where - - -- | Returns the bounds of the array - getBounds :: Ix i => a i e -> m (i,i) - - -- | Builds a new array, with every element initialised to the supplied - -- value. - newArray :: Ix i => (i,i) -> e -> m (a i e) - - -- | Builds a new array, with every element initialised to an - -- undefined value. In a monadic context in which operations must - -- be deterministic (e.g. the ST monad), the array elements are - -- initialised to a fixed but undefined value, such as zero. - newArray_ :: Ix i => (i,i) -> m (a i e) - - -- | Builds a new array, with every element initialised to an undefined - -- value. - unsafeNewArray_ :: Ix i => (i,i) -> m (a i e) - - unsafeRead :: Ix i => a i e -> Int -> m e - unsafeWrite :: Ix i => a i e -> Int -> e -> m () - - {-# INLINE newArray #-} - -- The INLINE is crucial, because until we know at least which monad - -- we are in, the code below allocates like crazy. So inline it, - -- in the hope that the context will know the monad. - newArray (l,u) init = do - marr <- unsafeNewArray_ (l,u) - sequence_ [unsafeWrite marr i init | i <- [0 .. rangeSize (l,u) - 1]] - return marr - - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = newArray (l,u) arrEleBottom - - {-# INLINE newArray_ #-} - newArray_ (l,u) = newArray (l,u) arrEleBottom - - -- newArray takes an initialiser which all elements of - -- the newly created array are initialised to. unsafeNewArray_ takes - -- no initialiser, it is assumed that the array is initialised with - -- "undefined" values. - - -- why not omit unsafeNewArray_? Because in the unboxed array - -- case we would like to omit the initialisation altogether if - -- possible. We can't do this for boxed arrays, because the - -- elements must all have valid values at all times in case of - -- garbage collection. - - -- why not omit newArray? Because in the boxed case, we can omit the - -- default initialisation with undefined values if we *do* know the - -- initial value and it is constant for all elements. - -{-# INLINE newListArray #-} --- | Constructs a mutable array from a list of initial elements. --- The list gives the elements of the array in ascending order --- beginning with the lowest index. -newListArray :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e) -newListArray (l,u) es = do - marr <- newArray_ (l,u) - let n = rangeSize (l,u) - let fillFromList i xs | i == n = return () - | otherwise = case xs of - [] -> return () - y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys - fillFromList 0 es - return marr - -{-# INLINE readArray #-} --- | Read an element from a mutable array -readArray :: (MArray a e m, Ix i) => a i e -> i -> m e -readArray marr i = do - (l,u) <- getBounds marr - unsafeRead marr (index (l,u) i) - -{-# INLINE writeArray #-} --- | Write an element in a mutable array -writeArray :: (MArray a e m, Ix i) => a i e -> i -> e -> m () -writeArray marr i e = do - (l,u) <- getBounds marr - unsafeWrite marr (index (l,u) i) e - -{-# INLINE getElems #-} --- | Return a list of all the elements of a mutable array -getElems :: (MArray a e m, Ix i) => a i e -> m [e] -getElems marr = do - (l,u) <- getBounds marr - sequence [unsafeRead marr i | i <- [0 .. rangeSize (l,u) - 1]] - -{-# INLINE getAssocs #-} --- | Return a list of all the associations of a mutable array, in --- index order. -getAssocs :: (MArray a e m, Ix i) => a i e -> m [(i, e)] -getAssocs marr = do - (l,u) <- getBounds marr - sequence [ do e <- unsafeRead marr (index (l,u) i); return (i,e) - | i <- range (l,u)] - -{-# INLINE mapArray #-} --- | Constructs a new array derived from the original array by applying a --- function to each of the elements. -mapArray :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e) -mapArray f marr = do - (l,u) <- getBounds marr - marr' <- newArray_ (l,u) - sequence_ [do - e <- unsafeRead marr i - unsafeWrite marr' i (f e) - | i <- [0 .. rangeSize (l,u) - 1]] - return marr' - -{-# INLINE mapIndices #-} --- | Constructs a new array derived from the original array by applying a --- function to each of the indices. -mapIndices :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e) -mapIndices (l,u) f marr = do - marr' <- newArray_ (l,u) - sequence_ [do - e <- readArray marr (f i) - unsafeWrite marr' (unsafeIndex (l,u) i) e - | i <- range (l,u)] - return marr' - ------------------------------------------------------------------------------ --- Polymorphic non-strict mutable arrays (ST monad) - -instance MArray (STArray s) e (ST s) where - {-# INLINE getBounds #-} - getBounds arr = return $! ArrST.boundsSTArray arr - {-# INLINE newArray #-} - newArray = ArrST.newSTArray - {-# INLINE unsafeRead #-} - unsafeRead = ArrST.unsafeReadSTArray - {-# INLINE unsafeWrite #-} - unsafeWrite = ArrST.unsafeWriteSTArray - -instance MArray (STArray s) e (Lazy.ST s) where - {-# INLINE getBounds #-} - getBounds arr = strictToLazyST (return $! ArrST.boundsSTArray arr) - {-# INLINE newArray #-} - newArray (l,u) e = strictToLazyST (ArrST.newSTArray (l,u) e) - {-# INLINE unsafeRead #-} - unsafeRead arr i = strictToLazyST (ArrST.unsafeReadSTArray arr i) - {-# INLINE unsafeWrite #-} - unsafeWrite arr i e = strictToLazyST (ArrST.unsafeWriteSTArray arr i e) - -#ifdef __HUGS__ -INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray") -#endif - ------------------------------------------------------------------------------ --- Flat unboxed mutable arrays (ST monad) - --- | A mutable array with unboxed elements, that can be manipulated in --- the 'ST' monad. The type arguments are as follows: --- --- * @s@: the state variable argument for the 'ST' type --- --- * @i@: the index type of the array (should be an instance of @Ix@) --- --- * @e@: the element type of the array. Only certain element types --- are supported. --- --- An 'STUArray' will generally be more efficient (in terms of both time --- and space) than the equivalent boxed version ('STArray') with the same --- element type. However, 'STUArray' is strict in its elements - so --- don\'t use 'STUArray' if you require the non-strictness that --- 'STArray' provides. -#ifdef __GLASGOW_HASKELL__ -data STUArray s i a = STUArray !i !i (MutableByteArray# s) -#endif -#ifdef __HUGS__ -data STUArray s i a = STUArray !i !i !(MutableByteArray s) -#endif - -INSTANCE_TYPEABLE3(STUArray,stUArrayTc,"STUArray") - -#ifdef __GLASGOW_HASKELL__ -instance MArray (STUArray s) Bool (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE newArray #-} - newArray (l,u) init = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) -> - case bOOL_WORD_SCALE n# of { n'# -> - let loop i# s3# | i# ==# n'# = s3# - | otherwise = - case writeWordArray# marr# i# e# s3# of { s4# -> - loop (i# +# 1#) s4# } in - case loop 0# s2# of { s3# -> - (# s3#, STUArray l u marr# #) }}}} - where - W# e# = if init then maxBound else 0 - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds False - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readWordArray# marr# (bOOL_INDEX i#) s1# of { (# s2#, e# #) -> - (# s2#, (e# `and#` bOOL_BIT i#) `neWord#` int2Word# 0# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) e = ST $ \s1# -> - case bOOL_INDEX i# of { j# -> - case readWordArray# marr# j# s1# of { (# s2#, old# #) -> - case if e then old# `or#` bOOL_BIT i# - else old# `and#` bOOL_NOT_BIT i# of { e# -> - case writeWordArray# marr# j# e# s2# of { s3# -> - (# s3#, () #) }}}} - -instance MArray (STUArray s) Char (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds (chr 0) - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readWideCharArray# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, C# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (C# e#) = ST $ \s1# -> - case writeWideCharArray# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Int (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readIntArray# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, I# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (I# e#) = ST $ \s1# -> - case writeIntArray# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Word (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readWordArray# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, W# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (W# e#) = ST $ \s1# -> - case writeWordArray# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) (Ptr a) (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds nullPtr - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readAddrArray# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, Ptr e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (Ptr e#) = ST $ \s1# -> - case writeAddrArray# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) (FunPtr a) (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds nullFunPtr - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readAddrArray# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, FunPtr e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (FunPtr e#) = ST $ \s1# -> - case writeAddrArray# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Float (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (fLOAT_SCALE n#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readFloatArray# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, F# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (F# e#) = ST $ \s1# -> - case writeFloatArray# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Double (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (dOUBLE_SCALE n#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readDoubleArray# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, D# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (D# e#) = ST $ \s1# -> - case writeDoubleArray# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) (StablePtr a) (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds (castPtrToStablePtr nullPtr) - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readStablePtrArray# marr# i# s1# of { (# s2#, e# #) -> - (# s2# , StablePtr e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (StablePtr e#) = ST $ \s1# -> - case writeStablePtrArray# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Int8 (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# n# s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readInt8Array# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, I8# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (I8# e#) = ST $ \s1# -> - case writeInt8Array# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Int16 (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readInt16Array# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, I16# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (I16# e#) = ST $ \s1# -> - case writeInt16Array# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Int32 (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readInt32Array# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, I32# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (I32# e#) = ST $ \s1# -> - case writeInt32Array# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Int64 (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readInt64Array# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, I64# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (I64# e#) = ST $ \s1# -> - case writeInt64Array# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Word8 (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# n# s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readWord8Array# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, W8# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (W8# e#) = ST $ \s1# -> - case writeWord8Array# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Word16 (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readWord16Array# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, W16# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (W16# e#) = ST $ \s1# -> - case writeWord16Array# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Word32 (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readWord32Array# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, W32# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (W32# e#) = ST $ \s1# -> - case writeWord32Array# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - -instance MArray (STUArray s) Word64 (ST s) where - {-# INLINE getBounds #-} - getBounds (STUArray l u _) = return (l,u) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) -> - (# s2#, STUArray l u marr# #) }} - {-# INLINE newArray_ #-} - newArray_ bounds = newArray bounds 0 - {-# INLINE unsafeRead #-} - unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> - case readWord64Array# marr# i# s1# of { (# s2#, e# #) -> - (# s2#, W64# e# #) } - {-# INLINE unsafeWrite #-} - unsafeWrite (STUArray _ _ marr#) (I# i#) (W64# e#) = ST $ \s1# -> - case writeWord64Array# marr# i# e# s1# of { s2# -> - (# s2#, () #) } - ------------------------------------------------------------------------------ --- Translation between elements and bytes - -bOOL_SCALE, bOOL_WORD_SCALE, - wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int# -bOOL_SCALE n# = (n# +# last#) `uncheckedIShiftRA#` 3# - where I# last# = SIZEOF_HSWORD * 8 - 1 -bOOL_WORD_SCALE n# = bOOL_INDEX (n# +# last#) - where I# last# = SIZEOF_HSWORD * 8 - 1 -wORD_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSWORD -dOUBLE_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSDOUBLE -fLOAT_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSFLOAT - -bOOL_INDEX :: Int# -> Int# -#if SIZEOF_HSWORD == 4 -bOOL_INDEX i# = i# `uncheckedIShiftRA#` 5# -#elif SIZEOF_HSWORD == 8 -bOOL_INDEX i# = i# `uncheckedIShiftRA#` 6# -#endif - -bOOL_BIT, bOOL_NOT_BIT :: Int# -> Word# -bOOL_BIT n# = int2Word# 1# `uncheckedShiftL#` (word2Int# (int2Word# n# `and#` mask#)) - where W# mask# = SIZEOF_HSWORD * 8 - 1 -bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# where W# mb# = maxBound -#endif /* __GLASGOW_HASKELL__ */ - -#ifdef __HUGS__ -newMBArray_ :: (Ix i, Storable e) => (i,i) -> ST s (STUArray s i e) -newMBArray_ = makeArray undefined - where - makeArray :: (Ix i, Storable e) => e -> (i,i) -> ST s (STUArray s i e) - makeArray dummy (l,u) = do - marr <- newMutableByteArray (rangeSize (l,u) * sizeOf dummy) - return (STUArray l u marr) - -unsafeReadMBArray :: Storable e => STUArray s i e -> Int -> ST s e -unsafeReadMBArray (STUArray _ _ marr) = readMutableByteArray marr - -unsafeWriteMBArray :: Storable e => STUArray s i e -> Int -> e -> ST s () -unsafeWriteMBArray (STUArray _ _ marr) = writeMutableByteArray marr - -getBoundsMBArray (STUArray l u _) = return (l,u) - -instance MArray (STUArray s) Bool (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ (l,u) = do - marr <- newMutableByteArray (bOOL_SCALE (rangeSize (l,u))) - return (STUArray l u marr) - newArray_ bounds = unsafeNewArray_ bounds - unsafeRead (STUArray _ _ marr) i = do - let ix = bOOL_INDEX i - bit = bOOL_SUBINDEX i - w <- readMutableByteArray marr ix - return (testBit (w::BitSet) bit) - unsafeWrite (STUArray _ _ marr) i e = do - let ix = bOOL_INDEX i - bit = bOOL_SUBINDEX i - w <- readMutableByteArray marr ix - writeMutableByteArray marr ix - (if e then setBit (w::BitSet) bit else clearBit w bit) - -instance MArray (STUArray s) Char (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) (Ptr a) (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) (FunPtr a) (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Float (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Double (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) (StablePtr a) (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int8 (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int16 (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int32 (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Int64 (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word8 (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word16 (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word32 (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -instance MArray (STUArray s) Word64 (ST s) where - getBounds = getBoundsMBArray - unsafeNewArray_ = newMBArray_ - newArray_ = unsafeNewArray_ - unsafeRead = unsafeReadMBArray - unsafeWrite = unsafeWriteMBArray - -type BitSet = Word8 - -bitSetSize = bitSize (0::BitSet) - -bOOL_SCALE :: Int -> Int -bOOL_SCALE n = (n + bitSetSize - 1) `div` bitSetSize - -bOOL_INDEX :: Int -> Int -bOOL_INDEX i = i `div` bitSetSize - -bOOL_SUBINDEX :: Int -> Int -bOOL_SUBINDEX i = i `mod` bitSetSize -#endif /* __HUGS__ */ - ------------------------------------------------------------------------------ --- Freezing - --- | Converts a mutable array (any instance of 'MArray') to an --- immutable array (any instance of 'IArray') by taking a complete --- copy of it. -freeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) -freeze marr = do - (l,u) <- getBounds marr - ies <- sequence [do e <- unsafeRead marr i; return (i,e) - | i <- [0 .. rangeSize (l,u) - 1]] - return (unsafeArray (l,u) ies) - -#ifdef __GLASGOW_HASKELL__ -freezeSTUArray :: Ix i => STUArray s i e -> ST s (UArray i e) -freezeSTUArray (STUArray l u marr#) = ST $ \s1# -> - case sizeofMutableByteArray# marr# of { n# -> - case newByteArray# n# s1# of { (# s2#, marr'# #) -> - case memcpy_freeze marr'# marr# (fromIntegral (I# n#)) of { IO m -> - case unsafeCoerce# m s2# of { (# s3#, _ #) -> - case unsafeFreezeByteArray# marr'# s3# of { (# s4#, arr# #) -> - (# s4#, UArray l u arr# #) }}}}} - -foreign import ccall unsafe "memcpy" - memcpy_freeze :: MutableByteArray# s -> MutableByteArray# s -> CSize - -> IO (Ptr a) - -{-# RULES -"freeze/STArray" freeze = ArrST.freezeSTArray -"freeze/STUArray" freeze = freezeSTUArray - #-} -#endif /* __GLASGOW_HASKELL__ */ - --- In-place conversion of mutable arrays to immutable ones places --- a proof obligation on the user: no other parts of your code can --- have a reference to the array at the point where you unsafely --- freeze it (and, subsequently mutate it, I suspect). - -{- | - Converts an mutable array into an immutable array. The - implementation may either simply cast the array from - one type to the other without copying the array, or it - may take a full copy of the array. - - Note that because the array is possibly not copied, any subsequent - modifications made to the mutable version of the array may be - shared with the immutable version. It is safe to use, therefore, if - the mutable version is never modified after the freeze operation. - - The non-copying implementation is supported between certain pairs - of array types only; one constraint is that the array types must - have identical representations. In GHC, The following pairs of - array types have a non-copying O(1) implementation of - 'unsafeFreeze'. Because the optimised versions are enabled by - specialisations, you will need to compile with optimisation (-O) to - get them. - - * 'Data.Array.IO.IOUArray' -> 'Data.Array.Unboxed.UArray' - - * 'Data.Array.ST.STUArray' -> 'Data.Array.Unboxed.UArray' - - * 'Data.Array.IO.IOArray' -> 'Data.Array.Array' - - * 'Data.Array.ST.STArray' -> 'Data.Array.Array' --} -{-# INLINE unsafeFreeze #-} -unsafeFreeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) -unsafeFreeze = freeze - -{-# RULES -"unsafeFreeze/STArray" unsafeFreeze = ArrST.unsafeFreezeSTArray -"unsafeFreeze/STUArray" unsafeFreeze = unsafeFreezeSTUArray - #-} - ------------------------------------------------------------------------------ --- Thawing - --- | Converts an immutable array (any instance of 'IArray') into a --- mutable array (any instance of 'MArray') by taking a complete copy --- of it. -thaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) -thaw arr = case bounds arr of - (l,u) -> do - marr <- newArray_ (l,u) - sequence_ [unsafeWrite marr i (unsafeAt arr i) - | i <- [0 .. rangeSize (l,u) - 1]] - return marr - -#ifdef __GLASGOW_HASKELL__ -thawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e) -thawSTUArray (UArray l u arr#) = ST $ \s1# -> - case sizeofByteArray# arr# of { n# -> - case newByteArray# n# s1# of { (# s2#, marr# #) -> - case memcpy_thaw marr# arr# (fromIntegral (I# n#)) of { IO m -> - case unsafeCoerce# m s2# of { (# s3#, _ #) -> - (# s3#, STUArray l u marr# #) }}}} - -foreign import ccall unsafe "memcpy" - memcpy_thaw :: MutableByteArray# s -> ByteArray# -> CSize - -> IO (Ptr a) - -{-# RULES -"thaw/STArray" thaw = ArrST.thawSTArray -"thaw/STUArray" thaw = thawSTUArray - #-} -#endif /* __GLASGOW_HASKELL__ */ - -#ifdef __HUGS__ -thawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e) -thawSTUArray (UArray l u arr) = do - marr <- thawByteArray arr - return (STUArray l u marr) -#endif - --- In-place conversion of immutable arrays to mutable ones places --- a proof obligation on the user: no other parts of your code can --- have a reference to the array at the point where you unsafely --- thaw it (and, subsequently mutate it, I suspect). - -{- | - Converts an immutable array into a mutable array. The - implementation may either simply cast the array from - one type to the other without copying the array, or it - may take a full copy of the array. - - Note that because the array is possibly not copied, any subsequent - modifications made to the mutable version of the array may be - shared with the immutable version. It is only safe to use, - therefore, if the immutable array is never referenced again in this - thread, and there is no possibility that it can be also referenced - in another thread. If you use an unsafeThaw/write/unsafeFreeze - sequence in a multi-threaded setting, then you must ensure that - this sequence is atomic with respect to other threads, or a garbage - collector crash may result (because the write may be writing to a - frozen array). - - The non-copying implementation is supported between certain pairs - of array types only; one constraint is that the array types must - have identical representations. In GHC, The following pairs of - array types have a non-copying O(1) implementation of - 'unsafeThaw'. Because the optimised versions are enabled by - specialisations, you will need to compile with optimisation (-O) to - get them. - - * 'Data.Array.Unboxed.UArray' -> 'Data.Array.IO.IOUArray' - - * 'Data.Array.Unboxed.UArray' -> 'Data.Array.ST.STUArray' - - * 'Data.Array.Array' -> 'Data.Array.IO.IOArray' - - * 'Data.Array.Array' -> 'Data.Array.ST.STArray' --} -{-# INLINE unsafeThaw #-} -unsafeThaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) -unsafeThaw = thaw - -#ifdef __GLASGOW_HASKELL__ -{-# INLINE unsafeThawSTUArray #-} -unsafeThawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e) -unsafeThawSTUArray (UArray l u marr#) = - return (STUArray l u (unsafeCoerce# marr#)) - -{-# RULES -"unsafeThaw/STArray" unsafeThaw = ArrST.unsafeThawSTArray -"unsafeThaw/STUArray" unsafeThaw = unsafeThawSTUArray - #-} -#endif /* __GLASGOW_HASKELL__ */ - --- | Casts an 'STUArray' with one element type into one with a --- different element type. All the elements of the resulting array --- are undefined (unless you know what you\'re doing...). - -#ifdef __GLASGOW_HASKELL__ -castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b) -castSTUArray (STUArray l u marr#) = return (STUArray l u marr#) -#endif - -#ifdef __HUGS__ -castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b) -castSTUArray (STUArray l u marr) = return (STUArray l u marr) -#endif diff --git a/Data/Array/Diff.hs b/Data/Array/Diff.hs deleted file mode 100644 index 3e86f89..0000000 --- a/Data/Array/Diff.hs +++ /dev/null @@ -1,423 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Array.Diff --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.IArray) --- --- Functional arrays with constant-time update. --- ------------------------------------------------------------------------------ - -module Data.Array.Diff ( - - -- * Diff array types - - -- | Diff arrays have an immutable interface, but rely on internal - -- updates in place to provide fast functional update operator - -- '//'. - -- - -- When the '//' operator is applied to a diff array, its contents - -- are physically updated in place. The old array silently changes - -- its representation without changing the visible behavior: - -- it stores a link to the new current array along with the - -- difference to be applied to get the old contents. - -- - -- So if a diff array is used in a single-threaded style, - -- i.e. after '//' application the old version is no longer used, - -- @a'!'i@ takes O(1) time and @a '//' d@ takes O(@length d@). - -- Accessing elements of older versions gradually becomes slower. - -- - -- Updating an array which is not current makes a physical copy. - -- The resulting array is unlinked from the old family. So you - -- can obtain a version which is guaranteed to be current and - -- thus have fast element access by @a '//' []@. - - -- Possible improvement for the future (not implemented now): - -- make it possible to say "I will make an update now, but when - -- I later return to the old version, I want it to mutate back - -- instead of being copied". - - IOToDiffArray, -- data IOToDiffArray - -- (a :: * -> * -> *) -- internal mutable array - -- (i :: *) -- indices - -- (e :: *) -- elements - - -- | Type synonyms for the two most important IO array types. - - -- Two most important diff array types are fully polymorphic - -- lazy boxed DiffArray: - DiffArray, -- = IOToDiffArray IOArray - -- ...and strict unboxed DiffUArray, working only for elements - -- of primitive types but more compact and usually faster: - DiffUArray, -- = IOToDiffArray IOUArray - - -- * Overloaded immutable array interface - - -- | Module "Data.Array.IArray" provides the interface of diff arrays. - -- They are instances of class 'IArray'. - module Data.Array.IArray, - - -- * Low-level interface - - -- | These are really internal functions, but you will need them - -- to make further 'IArray' instances of various diff array types - -- (for either more 'MArray' types or more unboxed element types). - newDiffArray, readDiffArray, replaceDiffArray - ) - where - ------------------------------------------------------------------------- --- Imports. - -import Prelude - -import Data.Ix -import Data.Array.Base -import Data.Array.IArray -import Data.Array.IO - -import Foreign.Ptr ( Ptr, FunPtr ) -import Foreign.StablePtr ( StablePtr ) -import Data.Int ( Int8, Int16, Int32, Int64 ) -import Data.Word ( Word, Word8, Word16, Word32, Word64 ) - -import System.IO.Unsafe ( unsafePerformIO ) -import Control.Exception ( evaluate ) -import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, readMVar ) - ------------------------------------------------------------------------- --- Diff array types. - --- | An arbitrary 'MArray' type living in the 'IO' monad can be converted --- to a diff array. - -newtype IOToDiffArray a i e = - DiffArray {varDiffArray :: MVar (DiffArrayData a i e)} - --- Internal representation: either a mutable array, or a link to --- another diff array patched with a list of index+element pairs. -data DiffArrayData a i e = Current (a i e) - | Diff (IOToDiffArray a i e) [(Int, e)] - --- | Fully polymorphic lazy boxed diff array. -type DiffArray = IOToDiffArray IOArray - --- | Strict unboxed diff array, working only for elements --- of primitive types but more compact and usually faster than 'DiffArray'. -type DiffUArray = IOToDiffArray IOUArray - --- Having 'MArray a e IO' in instance context would require --- -fallow-undecidable-instances, so each instance is separate here. - ------------------------------------------------------------------------- --- Showing DiffArrays - -instance (Ix ix, Show ix, Show e) => Show (DiffArray ix e) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Char) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Float) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Double) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int8) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int16) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int32) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Int64) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word8) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word16) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word32) where - showsPrec = showsIArray - -instance (Ix ix, Show ix) => Show (DiffUArray ix Word64) where - showsPrec = showsIArray - ------------------------------------------------------------------------- --- Boring instances. - -instance IArray (IOToDiffArray IOArray) e where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray1` ies - -instance IArray (IOToDiffArray IOUArray) Char where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) (Ptr a) where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) (FunPtr a) where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Float where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Double where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) (StablePtr a) where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int8 where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int16 where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int32 where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Int64 where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word8 where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word16 where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word32 where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - -instance IArray (IOToDiffArray IOUArray) Word64 where - bounds a = unsafePerformIO $ boundsDiffArray a - unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies - unsafeAt a i = unsafePerformIO $ a `readDiffArray` i - unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies - - - ------------------------------------------------------------------------- --- The important stuff. - -newDiffArray :: (MArray a e IO, Ix i) - => (i,i) - -> [(Int, e)] - -> IO (IOToDiffArray a i e) -newDiffArray (l,u) ies = do - a <- newArray_ (l,u) - sequence_ [unsafeWrite a i e | (i, e) <- ies] - var <- newMVar (Current a) - return (DiffArray var) - -readDiffArray :: (MArray a e IO, Ix i) - => IOToDiffArray a i e - -> Int - -> IO e -a `readDiffArray` i = do - d <- readMVar (varDiffArray a) - case d of - Current a' -> unsafeRead a' i - Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies) - -replaceDiffArray :: (MArray a e IO, Ix i) - => IOToDiffArray a i e - -> [(Int, e)] - -> IO (IOToDiffArray a i e) -a `replaceDiffArray` ies = do - d <- takeMVar (varDiffArray a) - case d of - Current a' -> case ies of - [] -> do - -- We don't do the copy when there is nothing to change - -- and this is the current version. But see below. - putMVar (varDiffArray a) d - return a - _:_ -> do - diff <- sequence [do e <- unsafeRead a' i; return (i, e) - | (i, _) <- ies] - sequence_ [unsafeWrite a' i e | (i, e) <- ies] - var' <- newMVar (Current a') - putMVar (varDiffArray a) (Diff (DiffArray var') diff) - return (DiffArray var') - Diff _ _ -> do - -- We still do the copy when there is nothing to change - -- but this is not the current version. So you can use - -- 'a // []' to make sure that the resulting array has - -- fast element access. - putMVar (varDiffArray a) d - a' <- thawDiffArray a - -- thawDiffArray gives a fresh array which we can - -- safely mutate. - sequence_ [unsafeWrite a' i e | (i, e) <- ies] - var' <- newMVar (Current a') - return (DiffArray var') - --- The elements of the diff list might recursively reference the --- array, so we must seq them before taking the MVar to avoid --- deadlock. -replaceDiffArray1 :: (MArray a e IO, Ix i) - => IOToDiffArray a i e - -> [(Int, e)] - -> IO (IOToDiffArray a i e) -a `replaceDiffArray1` ies = do - mapM_ (evaluate . fst) ies - a `replaceDiffArray` ies - --- If the array contains unboxed elements, then the elements of the --- diff list may also recursively reference the array from inside --- replaceDiffArray, so we must seq them too. -replaceDiffArray2 :: (MArray a e IO, Ix i) - => IOToDiffArray a i e - -> [(Int, e)] - -> IO (IOToDiffArray a i e) -a `replaceDiffArray2` ies = do - mapM_ (\(a,b) -> do evaluate a; evaluate b) ies - a `replaceDiffArray` ies - - -boundsDiffArray :: (MArray a e IO, Ix ix) - => IOToDiffArray a ix e - -> IO (ix,ix) -boundsDiffArray a = do - d <- readMVar (varDiffArray a) - case d of - Current a' -> getBounds a' - Diff a' _ -> boundsDiffArray a' - -freezeDiffArray :: (MArray a e IO, Ix ix) - => a ix e - -> IO (IOToDiffArray a ix e) -freezeDiffArray a = do - (l,u) <- getBounds a - a' <- newArray_ (l,u) - sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]] - var <- newMVar (Current a') - return (DiffArray var) - -{-# RULES -"freeze/DiffArray" freeze = freezeDiffArray - #-} - --- unsafeFreezeDiffArray is really unsafe. Better don't use the old --- array at all after freezing. The contents of the source array will --- be changed when '//' is applied to the resulting array. - -unsafeFreezeDiffArray :: (MArray a e IO, Ix ix) - => a ix e - -> IO (IOToDiffArray a ix e) -unsafeFreezeDiffArray a = do - var <- newMVar (Current a) - return (DiffArray var) - -{-# RULES -"unsafeFreeze/DiffArray" unsafeFreeze = unsafeFreezeDiffArray - #-} - -thawDiffArray :: (MArray a e IO, Ix ix) - => IOToDiffArray a ix e - -> IO (a ix e) -thawDiffArray a = do - d <- readMVar (varDiffArray a) - case d of - Current a' -> do - (l,u) <- getBounds a' - a'' <- newArray_ (l,u) - sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize (l,u) - 1]] - return a'' - Diff a' ies -> do - a'' <- thawDiffArray a' - sequence_ [unsafeWrite a'' i e | (i, e) <- ies] - return a'' - -{-# RULES -"thaw/DiffArray" thaw = thawDiffArray - #-} - --- unsafeThawDiffArray is really unsafe. Better don't use the old --- array at all after thawing. The contents of the resulting array --- will be changed when '//' is applied to the source array. - -unsafeThawDiffArray :: (MArray a e IO, Ix ix) - => IOToDiffArray a ix e - -> IO (a ix e) -unsafeThawDiffArray a = do - d <- readMVar (varDiffArray a) - case d of - Current a' -> return a' - Diff a' ies -> do - a'' <- unsafeThawDiffArray a' - sequence_ [unsafeWrite a'' i e | (i, e) <- ies] - return a'' - -{-# RULES -"unsafeThaw/DiffArray" unsafeThaw = unsafeThawDiffArray - #-} diff --git a/Data/Array/IArray.hs b/Data/Array/IArray.hs deleted file mode 100644 index 2a88764..0000000 --- a/Data/Array/IArray.hs +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Array.IArray --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.Base) --- --- Immutable arrays, with an overloaded interface. For array types which --- can be used with this interface, see the 'Array' type exported by this --- module, and the "Data.Array.Unboxed" and "Data.Array.Diff" modules. --- ------------------------------------------------------------------------------ - -module Data.Array.IArray ( - -- * Array classes - IArray, -- :: (* -> * -> *) -> * -> class - - module Data.Ix, - - -- * Immutable non-strict (boxed) arrays - Array, - - -- * Array construction - array, -- :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e - listArray, -- :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e - accumArray, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e - - -- * Accessing arrays - (!), -- :: (IArray a e, Ix i) => a i e -> i -> e - bounds, -- :: (HasBounds a, Ix i) => a i e -> (i,i) - indices, -- :: (HasBounds a, Ix i) => a i e -> [i] - elems, -- :: (IArray a e, Ix i) => a i e -> [e] - assocs, -- :: (IArray a e, Ix i) => a i e -> [(i, e)] - - -- * Incremental array updates - (//), -- :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e - accum, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e - - -- * Derived arrays - amap, -- :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e - ixmap, -- :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e - ) where - -import Prelude - -import Data.Ix -import Data.Array (Array) -import Data.Array.Base diff --git a/Data/Array/IO.hs b/Data/Array/IO.hs deleted file mode 100644 index 1231683..0000000 --- a/Data/Array/IO.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# OPTIONS_GHC -#include "HsBase.h" #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Array.IO --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.MArray) --- --- Mutable boxed and unboxed arrays in the IO monad. --- ------------------------------------------------------------------------------ - -module Data.Array.IO ( - -- * @IO@ arrays with boxed elements - IOArray, -- instance of: Eq, Typeable - - -- * @IO@ arrays with unboxed elements - IOUArray, -- instance of: Eq, Typeable - castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b) - - -- * Overloaded mutable array interface - module Data.Array.MArray, - - -- * Doing I\/O with @IOUArray@s - hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int - hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO () - ) where - -import Prelude - -import Data.Array.Base -import Data.Array.IO.Internals -import Data.Array ( Array ) -import Data.Array.MArray -import Data.Int -import Data.Word - -#ifdef __GLASGOW_HASKELL__ -import Foreign -import Foreign.C - -import GHC.Arr -import GHC.IOBase -import GHC.Handle -#else -import Data.Char -import System.IO -import System.IO.Error -#endif - -#ifdef __GLASGOW_HASKELL__ ------------------------------------------------------------------------------ --- Freezing - -freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e) -freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr) - -freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) -freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr) - -{-# RULES -"freeze/IOArray" freeze = freezeIOArray -"freeze/IOUArray" freeze = freezeIOUArray - #-} - -{-# INLINE unsafeFreezeIOArray #-} -unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e) -unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr) - -{-# INLINE unsafeFreezeIOUArray #-} -unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) -unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr) - -{-# RULES -"unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray -"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray - #-} - ------------------------------------------------------------------------------ --- Thawing - -thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e) -thawIOArray arr = stToIO $ do - marr <- thawSTArray arr - return (IOArray marr) - -thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) -thawIOUArray arr = stToIO $ do - marr <- thawSTUArray arr - return (IOUArray marr) - -{-# RULES -"thaw/IOArray" thaw = thawIOArray -"thaw/IOUArray" thaw = thawIOUArray - #-} - -{-# INLINE unsafeThawIOArray #-} -unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e) -unsafeThawIOArray arr = stToIO $ do - marr <- unsafeThawSTArray arr - return (IOArray marr) - -{-# INLINE unsafeThawIOUArray #-} -unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) -unsafeThawIOUArray arr = stToIO $ do - marr <- unsafeThawSTUArray arr - return (IOUArray marr) - -{-# RULES -"unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray -"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray - #-} - --- --------------------------------------------------------------------------- --- hGetArray - --- | Reads a number of 'Word8's from the specified 'Handle' directly --- into an array. -hGetArray - :: Handle -- ^ Handle to read from - -> IOUArray Int Word8 -- ^ Array in which to place the values - -> Int -- ^ Number of 'Word8's to read - -> IO Int - -- ^ Returns: the number of 'Word8's actually - -- read, which might be smaller than the number requested - -- if the end of file was reached. - -hGetArray handle (IOUArray (STUArray l u ptr)) count - | count == 0 - = return 0 - | count < 0 || count > rangeSize (l,u) - = illegalBufferSize handle "hGetArray" count - | otherwise = do - wantReadableHandle "hGetArray" handle $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref - if bufferEmpty buf - then readChunk fd is_stream ptr 0 count - else do - let avail = w - r - copied <- if (count >= avail) - then do - memcpy_ba_baoff ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - return avail - else do - memcpy_ba_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return count - - let remaining = count - copied - if remaining > 0 - then do rest <- readChunk fd is_stream ptr copied remaining - return (rest + copied) - else return count - -readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int -readChunk fd is_stream ptr init_off bytes = loop init_off bytes - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return (off - init_off) - loop off bytes = do - r' <- readRawBuffer "readChunk" (fromIntegral fd) is_stream ptr - (fromIntegral off) (fromIntegral bytes) - let r = fromIntegral r' - if r == 0 - then return (off - init_off) - else loop (off + r) (bytes - r) - --- --------------------------------------------------------------------------- --- hPutArray - --- | Writes an array of 'Word8' to the specified 'Handle'. -hPutArray - :: Handle -- ^ Handle to write to - -> IOUArray Int Word8 -- ^ Array to write from - -> Int -- ^ Number of 'Word8's to write - -> IO () - -hPutArray handle (IOUArray (STUArray l u raw)) count - | count == 0 - = return () - | count < 0 || count > rangeSize (l,u) - = illegalBufferSize handle "hPutArray" count - | otherwise - = do wantWritableHandle "hPutArray" handle $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do - - old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } - <- readIORef ref - - -- enough room in handle buffer? - if (size - w > count) - -- There's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return () - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd stream old_buf - writeIORef ref flushed_buf - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=count } - flushWriteBuffer fd stream this_buf - return () - --- --------------------------------------------------------------------------- --- Internal Utils - -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn sz = - ioException (IOError (Just handle) - InvalidArgument fn - ("illegal buffer size " ++ showsPrec 9 (sz::Int) []) - Nothing) - -#else /* !__GLASGOW_HASKELL__ */ -hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int -hGetArray handle arr count = do - bds <- getBounds arr - if count < 0 || count > rangeSize bds - then illegalBufferSize handle "hGetArray" count - else get 0 - where - get i | i == count = return i - | otherwise = do - error_or_c <- try (hGetChar handle) - case error_or_c of - Left ex - | isEOFError ex -> return i - | otherwise -> ioError ex - Right c -> do - unsafeWrite arr i (fromIntegral (ord c)) - get (i+1) - -hPutArray :: Handle -> IOUArray Int Word8 -> Int -> IO () -hPutArray handle arr count = do - bds <- getBounds arr - if count < 0 || count > rangeSize bds - then illegalBufferSize handle "hPutArray" count - else put 0 - where - put i | i == count = return () - | otherwise = do - w <- unsafeRead arr i - hPutChar handle (chr (fromIntegral w)) - put (i+1) - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize _ fn sz = ioError $ - userError (fn ++ ": illegal buffer size " ++ showsPrec 9 (sz::Int) []) -#endif /* !__GLASGOW_HASKELL__ */ diff --git a/Data/Array/IO/Internals.hs b/Data/Array/IO/Internals.hs deleted file mode 100644 index 045ce8d..0000000 --- a/Data/Array/IO/Internals.hs +++ /dev/null @@ -1,356 +0,0 @@ -{-# OPTIONS_GHC -#include "HsBase.h" #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Array.IO.Internal --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.Base) --- --- Mutable boxed and unboxed arrays in the IO monad. --- ------------------------------------------------------------------------------ - --- #hide -module Data.Array.IO.Internals ( - IOArray(..), -- instance of: Eq, Typeable - IOUArray(..), -- instance of: Eq, Typeable - castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b) - ) where - -import Prelude - -import Data.Array.MArray -import Data.Int -import Data.Word -import Data.Typeable - -#ifdef __HUGS__ -import Hugs.IOArray -#endif - -import Control.Monad.ST ( RealWorld, stToIO ) -import Foreign.Ptr ( Ptr, FunPtr ) -import Foreign.StablePtr ( StablePtr ) -import Data.Array.Base - -#ifdef __GLASGOW_HASKELL__ -import GHC.IOBase -import GHC.Base -#endif /* __GLASGOW_HASKELL__ */ - -#include "Typeable.h" - -INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray") - ------------------------------------------------------------------------------ --- | Instance declarations for 'IOArray's - -instance MArray IOArray e IO where -#if defined(__HUGS__) - getBounds = return . boundsIOArray -#elif defined(__GLASGOW_HASKELL__) - {-# INLINE getBounds #-} - getBounds (IOArray marr) = stToIO $ getBounds marr -#endif - newArray = newIOArray - unsafeRead = unsafeReadIOArray - unsafeWrite = unsafeWriteIOArray - ------------------------------------------------------------------------------ --- Flat unboxed mutable arrays (IO monad) - --- | Mutable, unboxed, strict arrays in the 'IO' monad. The type --- arguments are as follows: --- --- * @i@: the index type of the array (should be an instance of 'Ix') --- --- * @e@: the element type of the array. Only certain element types --- are supported: see "Data.Array.MArray" for a list of instances. --- -newtype IOUArray i e = IOUArray (STUArray RealWorld i e) - -INSTANCE_TYPEABLE2(IOUArray,iOUArrayTc,"IOUArray") - -instance MArray IOUArray Bool IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Char IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray (Ptr a) IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray (FunPtr a) IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Float IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Double IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray (StablePtr a) IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int8 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int16 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int32 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int64 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word8 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word16 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word32 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word64 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - --- | Casts an 'IOUArray' with one element type into one with a --- different element type. All the elements of the resulting array --- are undefined (unless you know what you\'re doing...). -castIOUArray :: IOUArray ix a -> IO (IOUArray ix b) -castIOUArray (IOUArray marr) = stToIO $ do - marr' <- castSTUArray marr - return (IOUArray marr') - diff --git a/Data/Array/MArray.hs b/Data/Array/MArray.hs deleted file mode 100644 index 95fae97..0000000 --- a/Data/Array/MArray.hs +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Array.MArray --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.Base) --- --- An overloaded interface to mutable arrays. For array types which can be --- used with this interface, see "Data.Array.IO", "Data.Array.ST", --- and "Data.Array.Storable". --- ------------------------------------------------------------------------------ - -module Data.Array.MArray ( - -- * Class of mutable array types - MArray, -- :: (* -> * -> *) -> * -> (* -> *) -> class - - -- * The @Ix@ class and operations - module Data.Ix, - - -- * Constructing mutable arrays - newArray, -- :: (MArray a e m, Ix i) => (i,i) -> e -> m (a i e) - newArray_, -- :: (MArray a e m, Ix i) => (i,i) -> m (a i e) - newListArray, -- :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e) - - -- * Reading and writing mutable arrays - readArray, -- :: (MArray a e m, Ix i) => a i e -> i -> m e - writeArray, -- :: (MArray a e m, Ix i) => a i e -> i -> e -> m () - - -- * Derived arrays - mapArray, -- :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e) - mapIndices, -- :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e) - - -- * Deconstructing mutable arrays - getBounds, -- :: (MArray a e m, Ix i) => a i e -> m (i,i) - getElems, -- :: (MArray a e m, Ix i) => a i e -> m [e] - getAssocs, -- :: (MArray a e m, Ix i) => a i e -> m [(i, e)] - - -- * Conversions between mutable and immutable arrays - freeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) - unsafeFreeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) - thaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) - unsafeThaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) - ) where - -import Prelude - -import Data.Ix -#ifdef __HADDOCK__ -import Data.Array.IArray -#endif -import Data.Array.Base diff --git a/Data/Array/ST.hs b/Data/Array/ST.hs deleted file mode 100644 index 828ae63..0000000 --- a/Data/Array/ST.hs +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Array.ST --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.MArray) --- --- Mutable boxed and unboxed arrays in the 'Control.Monad.ST.ST' monad. --- ------------------------------------------------------------------------------ - -module Data.Array.ST ( - - -- * Boxed arrays - STArray, -- instance of: Eq, MArray - runSTArray, - - -- * Unboxed arrays - STUArray, -- instance of: Eq, MArray - runSTUArray, - castSTUArray, -- :: STUArray s i a -> ST s (STUArray s i b) - - -- * Overloaded mutable array interface - module Data.Array.MArray, - ) where - -import Prelude - -import Data.Array.MArray -import Data.Array.Base ( STUArray, castSTUArray, UArray, unsafeFreezeSTUArray ) -import Control.Monad.ST ( ST, runST ) - -#ifdef __HUGS__ -import Hugs.Array ( Array ) -import Hugs.ST ( STArray, unsafeFreezeSTArray ) -#endif - -#ifdef __GLASGOW_HASKELL__ -import GHC.Arr ( STArray, Array, unsafeFreezeSTArray ) -#endif - --- | A safe way to create and work with a mutable array before returning an --- immutable array for later perusal. This function avoids copying --- the array before returning it - it uses 'unsafeFreeze' internally, but --- this wrapper is a safe interface to that function. --- -runSTArray :: (Ix i) - => (forall s . ST s (STArray s i e)) - -> Array i e -runSTArray st = runST (st >>= unsafeFreezeSTArray) - --- | A safe way to create and work with an unboxed mutable array before --- returning an immutable array for later perusal. This function --- avoids copying the array before returning it - it uses --- 'unsafeFreeze' internally, but this wrapper is a safe interface to --- that function. --- -runSTUArray :: (Ix i) - => (forall s . ST s (STUArray s i e)) - -> UArray i e -runSTUArray st = runST (st >>= unsafeFreezeSTUArray) - - --- INTERESTING... this is the type we'd like to give to runSTUArray: --- --- runSTUArray :: (Ix i, IArray UArray e, --- forall s. MArray (STUArray s) e (ST s)) --- => (forall s . ST s (STUArray s i e)) --- -> UArray i e --- --- Note the quantified constraint. We dodged the problem by using --- unsafeFreezeSTUArray directly in the defn of runSTUArray above, but --- this essentially constrains us to a single unsafeFreeze for all STUArrays --- (in theory we might have a different one for certain element types). diff --git a/Data/Array/Storable.hs b/Data/Array/Storable.hs deleted file mode 100644 index 68d8106..0000000 --- a/Data/Array/Storable.hs +++ /dev/null @@ -1,94 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Array.Storable --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.MArray) --- --- A storable array is an IO-mutable array which stores its --- contents in a contiguous memory block living in the C --- heap. Elements are stored according to the class 'Storable'. --- You can obtain the pointer to the array contents to manipulate --- elements from languages like C. --- --- It is similar to 'Data.Array.IO.IOUArray' but slower. --- Its advantage is that it's compatible with C. --- ------------------------------------------------------------------------------ - -module Data.Array.Storable ( - - -- * Arrays of 'Storable' things. - StorableArray, -- data StorableArray index element - -- -- index type must be in class Ix - -- -- element type must be in class Storable - - -- * Overloaded mutable array interface - -- | Module "Data.Array.MArray" provides the interface of storable arrays. - -- They are instances of class 'MArray' (with the 'IO' monad). - module Data.Array.MArray, - - -- * Accessing the pointer to the array contents - withStorableArray, -- :: StorableArray i e -> (Ptr e -> IO a) -> IO a - - touchStorableArray, -- :: StorableArray i e -> IO () - - unsafeForeignPtrToStorableArray - ) - where - -import Prelude - -import Data.Array.Base -import Data.Array.MArray -import Foreign hiding (newArray) - --- |The array type -data StorableArray i e = StorableArray !i !i !(ForeignPtr e) - -instance Storable e => MArray StorableArray e IO where - getBounds (StorableArray l u _) = return (l,u) - - newArray (l,u) init = do - fp <- mallocForeignPtrArray size - withForeignPtr fp $ \a -> - sequence_ [pokeElemOff a i init | i <- [0..size-1]] - return (StorableArray l u fp) - where - size = rangeSize (l,u) - - unsafeNewArray_ (l,u) = do - fp <- mallocForeignPtrArray (rangeSize (l,u)) - return (StorableArray l u fp) - - newArray_ = unsafeNewArray_ - - unsafeRead (StorableArray _ _ fp) i = - withForeignPtr fp $ \a -> peekElemOff a i - - unsafeWrite (StorableArray _ _ fp) i e = - withForeignPtr fp $ \a -> pokeElemOff a i e - --- |The pointer to the array contents is obtained by 'withStorableArray'. --- The idea is similar to 'ForeignPtr' (used internally here). --- The pointer should be used only during execution of the 'IO' action --- retured by the function passed as argument to 'withStorableArray'. -withStorableArray :: StorableArray i e -> (Ptr e -> IO a) -> IO a -withStorableArray (StorableArray _ _ fp) f = withForeignPtr fp f - --- |If you want to use it afterwards, ensure that you --- 'touchStorableArray' after the last use of the pointer, --- so the array is not freed too early. -touchStorableArray :: StorableArray i e -> IO () -touchStorableArray (StorableArray _ _ fp) = touchForeignPtr fp - --- |Construct a 'StorableArray' from an arbitrary 'ForeignPtr'. It is --- the caller's responsibility to ensure that the 'ForeignPtr' points to --- an area of memory sufficient for the specified bounds. -unsafeForeignPtrToStorableArray - :: ForeignPtr e -> (i,i) -> IO (StorableArray i e) -unsafeForeignPtrToStorableArray p (l,u) = - return (StorableArray l u p) diff --git a/Data/Array/Unboxed.hs b/Data/Array/Unboxed.hs deleted file mode 100644 index 2e24fad..0000000 --- a/Data/Array/Unboxed.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Array.Unboxed --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.IArray) --- --- Unboxed immutable arrays. --- ------------------------------------------------------------------------------ - -module Data.Array.Unboxed ( - -- * Arrays with unboxed elements - UArray, - - -- * The overloaded immutable array interface - module Data.Array.IArray, - ) where - -import Prelude - -import Data.Array.IArray -import Data.Array.Base diff --git a/Data/PackedString.hs b/Data/PackedString.hs deleted file mode 100644 index e008401..0000000 --- a/Data/PackedString.hs +++ /dev/null @@ -1,447 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.PackedString --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- This API is deprecated. You might be able to use "Data.ByteString" --- or "Data.ByteString.Char8", provided you don't need full Unicode support. --- The long term aim is to provide a Unicode layer on "Data.ByteString", --- and then to provide a replacement for this "Data.PackedString" API based on --- that. --- ------------------------------------------------------------------------------ - --- Original GHC implementation by Bryan O\'Sullivan, --- rewritten to use UArray by Simon Marlow. - -module Data.PackedString - {-# DEPRECATED "use Data.ByteString, Data.ByteString.Char8, or plain String." #-} - ( - -- * The @PackedString@ type - PackedString, -- abstract, instances: Eq, Ord, Show, Typeable - - -- * Converting to and from @PackedString@s - packString, -- :: String -> PackedString - unpackPS, -- :: PackedString -> String - -#ifndef __NHC__ - -- * I\/O with @PackedString@s - hPutPS, -- :: Handle -> PackedString -> IO () - hGetPS, -- :: Handle -> Int -> IO PackedString -#endif - - -- * List-like manipulation functions - nilPS, -- :: PackedString - consPS, -- :: Char -> PackedString -> PackedString - headPS, -- :: PackedString -> Char - tailPS, -- :: PackedString -> PackedString - nullPS, -- :: PackedString -> Bool - appendPS, -- :: PackedString -> PackedString -> PackedString - lengthPS, -- :: PackedString -> Int - indexPS, -- :: PackedString -> Int -> Char - mapPS, -- :: (Char -> Char) -> PackedString -> PackedString - filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString - reversePS, -- :: PackedString -> PackedString - concatPS, -- :: [PackedString] -> PackedString - elemPS, -- :: Char -> PackedString -> Bool - substrPS, -- :: PackedString -> Int -> Int -> PackedString - takePS, -- :: Int -> PackedString -> PackedString - dropPS, -- :: Int -> PackedString -> PackedString - splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString) - - foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a - foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a - takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString - dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString - spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) - breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) - linesPS, -- :: PackedString -> [PackedString] - unlinesPS, -- :: [PackedString] -> PackedString - wordsPS, -- :: PackedString -> [PackedString] - unwordsPS, -- :: [PackedString] -> PackedString - splitPS, -- :: Char -> PackedString -> [PackedString] - splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString] - - joinPS, -- :: PackedString -> [PackedString] -> PackedString - - ) where - -import Prelude - -#ifndef __NHC__ - -import Data.Array.Unboxed -import Data.Array.IO -import Data.Typeable -import Data.Char -#ifdef __GLASGOW_HASKELL__ -import Data.Generics -#endif - -import System.IO - --- ----------------------------------------------------------------------------- --- PackedString type declaration - --- | A space-efficient representation of a 'String', which supports various --- efficient operations. A 'PackedString' contains full Unicode 'Char's. -newtype PackedString = PS (UArray Int Char) - --- ToDo: we could support "slices", i.e. include offset and length fields into --- the string, so that operations like take/drop could be O(1). Perhaps making --- a slice should be conditional on the ratio of the slice/string size to --- limit memory leaks. - -instance Eq PackedString where - (PS x) == (PS y) = x == y - -instance Ord PackedString where - compare (PS x) (PS y) = compare x y - ---instance Read PackedString: ToDo - -instance Show PackedString where - showsPrec p ps r = showsPrec p (unpackPS ps) r - -#include "Typeable.h" -INSTANCE_TYPEABLE0(PackedString,packedStringTc,"PackedString") - --- ----------------------------------------------------------------------------- --- Constructor functions - --- | The 'nilPS' value is the empty string. -nilPS :: PackedString -nilPS = PS (array (0,-1) []) - --- | The 'consPS' function prepends the given character to the --- given string. -consPS :: Char -> PackedString -> PackedString -consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better - --- | Convert a 'String' into a 'PackedString' -packString :: String -> PackedString -packString str = packNChars (length str) str - --- | The 'packNChars' function creates a 'PackedString' out of the --- first @len@ elements of the given 'String'. -packNChars :: Int -> [Char] -> PackedString -packNChars len str = PS (listArray (0,len-1) str) - --- ----------------------------------------------------------------------------- --- Destructor functions (taking PackedStrings apart) - --- | Convert a 'PackedString' into a 'String' -unpackPS :: PackedString -> String -unpackPS (PS ps) = elems ps - --- ----------------------------------------------------------------------------- --- List-mimicking functions for PackedStrings - --- | The 'lengthPS' function returns the length of the input list. Analogous to 'length'. -lengthPS :: PackedString -> Int -lengthPS (PS ps) = rangeSize (bounds ps) - --- | The 'indexPS' function returns the character in the string at the given position. -indexPS :: PackedString -> Int -> Char -indexPS (PS ps) i = ps ! i - --- | The 'headPS' function returns the first element of a 'PackedString' or throws an --- error if the string is empty. -headPS :: PackedString -> Char -headPS ps - | nullPS ps = error "Data.PackedString.headPS: head []" - | otherwise = indexPS ps 0 - --- | The 'tailPS' function returns the tail of a 'PackedString' or throws an error --- if the string is empty. -tailPS :: PackedString -> PackedString -tailPS ps - | len <= 0 = error "Data.PackedString.tailPS: tail []" - | len == 1 = nilPS - | otherwise = substrPS ps 1 (len - 1) - where - len = lengthPS ps - --- | The 'nullPS' function returns True iff the argument is null. -nullPS :: PackedString -> Bool -nullPS (PS ps) = rangeSize (bounds ps) == 0 - --- | The 'appendPS' function appends the second string onto the first. -appendPS :: PackedString -> PackedString -> PackedString -appendPS xs ys - | nullPS xs = ys - | nullPS ys = xs - | otherwise = concatPS [xs,ys] - --- | The 'mapPS' function applies a function to each character in the string. -mapPS :: (Char -> Char) -> PackedString -> PackedString -mapPS f (PS ps) = PS (amap f ps) - --- | The 'filterPS' function filters out the appropriate substring. -filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-} -filterPS pred ps = packString (filter pred (unpackPS ps)) - --- | The 'foldlPS' function behaves like 'foldl' on 'PackedString's. -foldlPS :: (a -> Char -> a) -> a -> PackedString -> a -foldlPS f b ps = foldl f b (unpackPS ps) - --- | The 'foldrPS' function behaves like 'foldr' on 'PackedString's. -foldrPS :: (Char -> a -> a) -> a -> PackedString -> a -foldrPS f v ps = foldr f v (unpackPS ps) - --- | The 'takePS' function takes the first @n@ characters of a 'PackedString'. -takePS :: Int -> PackedString -> PackedString -takePS n ps = substrPS ps 0 (n-1) - --- | The 'dropPS' function drops the first @n@ characters of a 'PackedString'. -dropPS :: Int -> PackedString -> PackedString -dropPS n ps = substrPS ps n (lengthPS ps - 1) - --- | The 'splitWithPS' function splits a 'PackedString' at a given index. -splitAtPS :: Int -> PackedString -> (PackedString, PackedString) -splitAtPS n ps = (takePS n ps, dropPS n ps) - --- | The 'takeWhilePS' function is analogous to the 'takeWhile' function. -takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString -takeWhilePS pred ps = packString (takeWhile pred (unpackPS ps)) - --- | The 'dropWhilePS' function is analogous to the 'dropWhile' function. -dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString -dropWhilePS pred ps = packString (dropWhile pred (unpackPS ps)) - --- | The 'elemPS' function returns True iff the given element is in the string. -elemPS :: Char -> PackedString -> Bool -elemPS c ps = c `elem` unpackPS ps - --- | The 'spanPS' function returns a pair containing the result of --- running both 'takeWhilePS' and 'dropWhilePS'. -spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) -spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps) - --- | The 'breakPS' function breaks a string at the first position which --- satisfies the predicate. -breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) -breakPS p ps = spanPS (not . p) ps - --- | The 'linesPS' function splits the input on line-breaks. -linesPS :: PackedString -> [PackedString] -linesPS ps = splitPS '\n' ps - --- | The 'unlinesPS' function concatenates the input list after --- interspersing newlines. -unlinesPS :: [PackedString] -> PackedString -unlinesPS = joinPS (packString "\n") - --- | The 'wordsPS' function is analogous to the 'words' function. -wordsPS :: PackedString -> [PackedString] -wordsPS ps = filter (not.nullPS) (splitWithPS isSpace ps) - --- | The 'unwordsPS' function is analogous to the 'unwords' function. -unwordsPS :: [PackedString] -> PackedString -unwordsPS = joinPS (packString " ") - --- | The 'reversePS' function reverses the string. -reversePS :: PackedString -> PackedString -reversePS ps = packString (reverse (unpackPS ps)) - --- | The 'concatPS' function concatenates a list of 'PackedString's. -concatPS :: [PackedString] -> PackedString -concatPS pss = packString (concat (map unpackPS pss)) - ------------------------------------------------------------- - --- | The 'joinPS' function takes a 'PackedString' and a list of 'PackedString's --- and concatenates the list after interspersing the first argument between --- each element of the list. -joinPS :: PackedString -> [PackedString] -> PackedString -joinPS filler pss = concatPS (splice pss) - where - splice [] = [] - splice [x] = [x] - splice (x:y:xs) = x:filler:splice (y:xs) - --- ToDo: the obvious generalisation -{- - Some properties that hold: - - * splitPS x ls = ls' - where False = any (map (x `elemPS`) ls') - - * joinPS (packString [x]) (splitPS x ls) = ls --} - --- | The 'splitPS' function splits the input string on each occurrence of the given 'Char'. -splitPS :: Char -> PackedString -> [PackedString] -splitPS c = splitWithPS (== c) - --- | The 'splitWithPS' function takes a character predicate and splits the input string --- at each character which satisfies the predicate. -splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString] -splitWithPS pred (PS ps) = - splitify 0 - where - len = lengthPS (PS ps) - - splitify n - | n >= len = [] - | otherwise = - let - break_pt = first_pos_that_satisfies pred ps len n - in - if break_pt == n then -- immediate match, empty substring - nilPS - : splitify (break_pt + 1) - else - substrPS (PS ps) n (break_pt - 1) -- leave out the matching character - : splitify (break_pt + 1) - -first_pos_that_satisfies pred ps len n = - case [ m | m <- [n..len-1], pred (ps ! m) ] of - [] -> len - (m:_) -> m - --- ----------------------------------------------------------------------------- --- Local utility functions - --- The definition of @_substrPS@ is essentially: --- @take (end - begin + 1) (drop begin str)@. - --- | The 'substrPS' function takes a 'PackedString' and two indices --- and returns the substring of the input string between (and including) --- these indices. -substrPS :: PackedString -> Int -> Int -> PackedString -substrPS (PS ps) begin end = packString [ ps ! i | i <- [begin..end] ] - --- ----------------------------------------------------------------------------- --- hPutPS - --- | Outputs a 'PackedString' to the specified 'Handle'. --- --- NOTE: the representation of the 'PackedString' in the file is assumed to --- be in the ISO-8859-1 encoding. In other words, only the least significant --- byte is taken from each character in the 'PackedString'. -hPutPS :: Handle -> PackedString -> IO () -hPutPS h (PS ps) = do - let l = lengthPS (PS ps) - arr <- newArray_ (0, l-1) - sequence_ [ writeArray arr i (fromIntegral (ord (ps ! i))) | i <- [0..l-1] ] - hPutArray h arr l - --- ----------------------------------------------------------------------------- --- hGetPS - --- | Read a 'PackedString' directly from the specified 'Handle'. --- This is far more efficient than reading the characters into a 'String' --- and then using 'packString'. --- --- NOTE: as with 'hPutPS', the string representation in the file is --- assumed to be ISO-8859-1. -hGetPS :: Handle -> Int -> IO PackedString -hGetPS h i = do - arr <- newArray_ (0, i-1) - l <- hGetArray h arr i - chars <- mapM (\i -> readArray arr i >>= return.chr.fromIntegral) [0..l-1] - return (packNChars l chars) - -#else /* __NHC__ */ - ---import Prelude hiding (append, break, concat, cons, drop, dropWhile, --- filter, foldl, foldr, head, length, lines, map, --- nil, null, reverse, span, splitAt, subst, tail, --- take, takeWhile, unlines, unwords, words) --- also hiding: Ix(..), Functor(..) -import qualified NHC.PackedString -import NHC.PackedString (PackedString,packString,unpackPS) -import List (intersperse) - - -nilPS :: PackedString -consPS :: Char -> PackedString -> PackedString -headPS :: PackedString -> Char -tailPS :: PackedString -> PackedString -nullPS :: PackedString -> Bool -appendPS :: PackedString -> PackedString -> PackedString -lengthPS :: PackedString -> Int -indexPS :: PackedString -> Int -> Char -mapPS :: (Char -> Char) -> PackedString -> PackedString -filterPS :: (Char -> Bool) -> PackedString -> PackedString -reversePS :: PackedString -> PackedString -concatPS :: [PackedString] -> PackedString -elemPS :: Char -> PackedString -> Bool -substrPS :: PackedString -> Int -> Int -> PackedString -takePS :: Int -> PackedString -> PackedString -dropPS :: Int -> PackedString -> PackedString -splitAtPS :: Int -> PackedString -> (PackedString, PackedString) - -foldlPS :: (a -> Char -> a) -> a -> PackedString -> a -foldrPS :: (Char -> a -> a) -> a -> PackedString -> a -takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString -dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString -spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) -breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) -linesPS :: PackedString -> [PackedString] -unlinesPS :: [PackedString] -> PackedString - -wordsPS :: PackedString -> [PackedString] -unwordsPS :: [PackedString] -> PackedString -splitPS :: Char -> PackedString -> [PackedString] -splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString] -joinPS :: PackedString -> [PackedString] -> PackedString - -nilPS = NHC.PackedString.nil -consPS = NHC.PackedString.cons -headPS = NHC.PackedString.head -tailPS = NHC.PackedString.tail -nullPS = NHC.PackedString.null -appendPS = NHC.PackedString.append -lengthPS = NHC.PackedString.length -indexPS p i = (unpackPS p) !! i -mapPS = NHC.PackedString.map -filterPS = NHC.PackedString.filter -reversePS = NHC.PackedString.reverse -concatPS = NHC.PackedString.concat -elemPS c p = c `elem` unpackPS p -substrPS = NHC.PackedString.substr -takePS = NHC.PackedString.take -dropPS = NHC.PackedString.drop -splitAtPS = NHC.PackedString.splitAt - -foldlPS = NHC.PackedString.foldl -foldrPS = NHC.PackedString.foldr -takeWhilePS = NHC.PackedString.takeWhile -dropWhilePS = NHC.PackedString.dropWhile -spanPS = NHC.PackedString.span -breakPS = NHC.PackedString.break -linesPS = NHC.PackedString.lines -unlinesPS = NHC.PackedString.unlines - -wordsPS = NHC.PackedString.words -unwordsPS = NHC.PackedString.unwords -splitPS c = splitWithPS (==c) -splitWithPS p = - map packString . split' p [] . unpackPS - where - split' :: (Char->Bool) -> String -> String -> [String] - split' pred [] [] = [] - split' pred acc [] = [reverse acc] - split' pred acc (x:xs) | pred x = reverse acc: split' pred [] xs - | otherwise = split' pred (x:acc) xs - -joinPS sep = concatPS . intersperse sep - -#endif - -#ifdef __GLASGOW_HASKELL__ -instance Data PackedString where - gunfold k z c = error "gunfold" - toConstr (PS _) = con_PS - dataTypeOf _ = ty_PackedString - -con_PS = mkConstr ty_PackedString "PS" [] Prefix -ty_PackedString = mkDataType "Data.PackedString.PackedString" [con_PS] -#endif diff --git a/base.cabal b/base.cabal index 08dd8f9..e425f53 100644 --- a/base.cabal +++ b/base.cabal @@ -84,15 +84,6 @@ Library { Control.Monad.ST, Control.Monad.ST.Lazy, Control.Monad.ST.Strict, - Data.Array, - Data.Array.Base, - Data.Array.Diff, - Data.Array.IArray, - Data.Array.IO, - Data.Array.MArray, - Data.Array.ST, - Data.Array.Storable, - Data.Array.Unboxed, Data.Bits, Data.Bool, Data.Char, @@ -110,7 +101,6 @@ Library { Data.Maybe, Data.Monoid, Data.Ord, - Data.PackedString, Data.Ratio, Data.STRef, Data.STRef.Lazy, @@ -160,8 +150,6 @@ Library { Text.Show, Text.Show.Functions Unsafe.Coerce - other-modules: - Data.Array.IO.Internals c-sources: cbits/PrelIOUtils.c cbits/WCsubst.c