diff --git a/ArrayRef.cabal b/ArrayRef.cabal new file mode 100644 --- /dev/null +++ b/ArrayRef.cabal @@ -0,0 +1,66 @@ +Name: ArrayRef +Version: 0.1 +Category: Data +Synopsis: Unboxed references, dynamic arrays and more +Description: This array library supports: unboxed references, + Monad-independent references, syntax sugar for mutable types, + a reimplemented Arrays library, changes in MArray usage, + and using dynamic (resizable) arrays +License: BSD3 +License-file: LICENSE +Stability: experimental +Author: Bulat Ziganshin +Maintainer: Bulat Ziganshin +Homepage: http://haskell.org/haskellwiki/Library/ArrayRef + +Build-type: Simple +Tested-with: GHC==6.8.2 +Build-Depends: base +Extensions: CPP, FlexibleContexts, FlexibleInstances, FunctionalDependencies, + KindSignatures, ForeignFunctionInterface, + MagicHash, RankNTypes, ScopedTypeVariables, TypeOperators, + TypeSynonymInstances, UnboxedTuples, UnliftedFFITypes +ghc-options: -O2 -Wall -optl-Wl,-s +ghc-prof-options: -prof -auto-all + +Exposed-modules: + Control.Concurrent.LockingBZ, + Control.Monad.STorIO, + Data.HasDefaultValue, + Data.Ref, + Data.SyntaxSugar, + Data.Unboxed, + Data.ArrayBZ.Boxed, + Data.ArrayBZ.Diff, + Data.ArrayBZ.Dynamic, + Data.ArrayBZ.IArray, + Data.ArrayBZ.IO, + Data.ArrayBZ.MArray, + Data.ArrayBZ.ST, + Data.ArrayBZ.Storable, + Data.ArrayBZ.Unboxed, + Data.ArrayBZ.Internals.Boxed, + Data.ArrayBZ.Internals.IArray, + Data.ArrayBZ.Internals.MArray, + Data.ArrayBZ.Internals.Unboxed, + Data.Ref.LazyST, + Data.Ref.Unboxed, + Data.Ref.Universal, + GHC.ArrBZ, + GHC.Unboxed +Extra-source-files: + README + TODO, + Hugs/Typeable.h, + Data/ArrayBZ/Internals/readme.txt, + Data/ArrayBZ/Internals/unused.hs, + Examples/SyntaxSugar.hs, + Examples/Universal.hs, + Examples/URef.hs, + Examples/Array/Boxed.hs, + Examples/Array/Diff.hs, + Examples/Array/Dynamic.hs, + Examples/Array/IO.hs, + Examples/Array/ST.hs, + Examples/Array/Storable.hs, + Examples/Array/Unboxed.hs diff --git a/Control/Concurrent/LockingBZ.hs b/Control/Concurrent/LockingBZ.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/LockingBZ.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE CPP, FunctionalDependencies, FlexibleInstances, MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.LockingBZ +-- Copyright : (c) Bulat Ziganshin 2006 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (concurrency) +-- +-- Attaching lock to immutable value. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.LockingBZ + ( + -- * Locking + + -- $intro + + -- ** The 'WithLocking h' type constructor + WithLocking(..), -- instance of Show + + -- ** Attaching lock to value + addLocking, -- :: h -> IO (WithLocking h) + withLocking, -- :: h -> (WithLocking h -> IO a) -> IO a + + -- ** Using value inside lock +#if defined (__GLASGOW_HASKELL__) || defined (__HUGS__) + Locking(..), +#else + lock, +#endif + + -- ** Promoting operations to use locks + liftLock1, + liftLock2, + liftLock3, + liftLock4, + liftLock5, + + ) where + +import Control.Concurrent.MVar +import Control.Exception as Exception + +{- $intro + +This library allows to attach lock to any immutable value so that access +to this value can be obtained only via the 'lock' operation that ensures +that this value will never be used at the same time by concurrent threads. +Lock attached to value by 'addLocking' operation, it's also possible to run +code block with locked version of some value by 'withLocking' operation. + +To work with value contained inside lock, you should use 'lock' operation; +it's usage is very like to using 'withMVar' for the same purpose, but you +don't got ability to return new value of internal data from the action +performed. On the other side, 'lock' operation is about two times faster +than 'withMVar' according to my tests. There are also 'liftLock*' +operations that simplifies promoting operations on original value to +operations on it's locked version. Hugs/GHC version of this library defines +'lock' as operation of class 'Locking' that opens possibility to define +alternative 'lock' implementations. + +First usage example - adding lock to mutable array and promoting the mutable +array with lock to support mutable array interface again. This can be done +with any objects what are accessed through some interface defined via type +class: + +> import Control.Concurrent.Locking +> +> type WithLocking2 a e m = WithLocking (a e m) +> +> instance (MArray a e m) => (MArray (WithLocking2 a) e m) where +> newArray lu e = newArray lu e >>= addLocking +> newArray_ lu = newArray_ lu >>= addLocking +> unsafeRead = liftLock2 unsafeRead +> unsafeWrite = liftLock3 unsafeWrite +> +> main = do arr <- newArray (0,9) 0 >>= addLocking +> readArray arr 0 >>= writeArray arr 1 +> ..... +> + +Another example where 'lock' operation used to get exclusive access to file +while performing sequence of operations on it: + +> main = do lh <- openBinaryFile "test" ReadMode >>= addLocking +> .... +> str <- readStringAt lh pos +> .... +> +> readStringAt lh pos = +> lock lh $ \h -> do +> saved_pos <- hTell h +> hSeek h AbsoluteSeek pos +> str <- hGetLine h +> hSeek h AbsoluteSeek saved_pos +> return str + +In this example, any thread can use 'readStringAt' on the same locked handle +without risk to interfere with each other's operation + +-} + + +-- ----------------------------------------------------------------------------- +-- 'WithLocking' type constructor and it's constructor functions + +-- | Type constructor that attaches lock to immutable value @h@ +data WithLocking h = WithLocking h !(MVar ()) + +instance (Show h) => Show (WithLocking h) where + show (WithLocking h _) = "WithLocking ("++ show h ++")" + +-- | Add lock to object to ensure it's proper use in concurrent threads +addLocking :: h -> IO (WithLocking h) +addLocking h = do + mvar <- newMVar () + return (WithLocking h mvar) + +-- | Run @action@ with locked version of object +withLocking :: h -> (WithLocking h -> IO a) -> IO a +withLocking h action = do + addLocking h >>= action + +-- ----------------------------------------------------------------------------- +-- 'lock' operation definition: use MPTC+FD for Hugs/GHC or simple function for +-- compilers that don't support MPTC+FD + +#if defined (__GLASGOW_HASKELL__) || defined (__HUGS__) + +-- | Define class of locking implementations, where 'lh' holds lock around 'h' +class Locking lh h | lh->h where + -- | Perform action while exclusively locking wrapped object + -- (faster analog of using 'withMVar' for the same purpose) + lock :: lh -> (h->IO a) -> IO a + +instance Locking (WithLocking h) h where + {-# INLINE lock #-} + lock + +#else + +{-# INLINE lock #-} +-- | Perform action while exclusively locking wrapped object +-- (faster analog of using 'withMVar' for the same purpose) +lock :: (WithLocking h) -> (h->IO a) -> IO a +lock + +#endif + (WithLocking h mvar) action = do + Exception.catch (do takeMVar mvar + result <- action h + putMVar mvar () + return result + ) + (\e -> do tryPutMVar mvar (); throw e) + +-- ----------------------------------------------------------------------------- +-- Helper operations - wrappers around 'lock' + +{-# INLINE liftLock1 #-} +-- | Lift 1-parameter action to operation on locked variable +liftLock1 action h = lock h (\a -> action a) + +{-# INLINE liftLock2 #-} +-- | Lift 2-parameter action to operation on locked variable +liftLock2 action h x = lock h (\a -> action a x) + +{-# INLINE liftLock3 #-} +-- | Lift 3-parameter action to operation on locked variable +liftLock3 action h x y = lock h (\a -> action a x y) + +{-# INLINE liftLock4 #-} +-- | Lift 4-parameter action to operation on locked variable +liftLock4 action h x y z = lock h (\a -> action a x y z) + +{-# INLINE liftLock5 #-} +-- | Lift 5-parameter action to operation on locked variable +liftLock5 action h x y z t = lock h (\a -> action a x y z t) + diff --git a/Control/Monad/STorIO.hs b/Control/Monad/STorIO.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/STorIO.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Control.Monad.STorIO + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +Unification of ST and IO operations! + +-} + +module Control.Monad.STorIO ( + STorIO(..), + IOSpecific, + IOSpecific2, + IOSpecific3, + ) +where + +#ifdef __GLASGOW_HASKELL__ + +import GHC.Unboxed + +#else + +import Control.Monad.ST +import qualified Control.Monad.ST.Lazy as Lazy + +-- --------------------------------------------------------------------------- +-- | That's all we need to unify ST and IO operations! + +class (Monad m) => STorIO m s | m->s where + mLift :: IO a -> m a + +instance STorIO (ST s) s where + {-# INLINE mLift #-} + mLift = unsafeIOToST + +instance STorIO (Lazy.ST s) s where + {-# INLINE mLift #-} + mLift = Lazy.unsafeIOToST + +instance STorIO IO () where + {-# INLINE mLift #-} + mLift = id + +-- | Type functions which converts universal ST/IO types to IO-specific ones +type IOSpecific a = a () +type IOSpecific2 a b = a () b +type IOSpecific3 a = a () + +#endif + diff --git a/Data/ArrayBZ/Boxed.hs b/Data/ArrayBZ/Boxed.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Boxed.hs @@ -0,0 +1,26 @@ +{- | + Module : Data.ArrayBZ.Boxed + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +Boxed arrays + +-} + +module Data.ArrayBZ.Boxed ( + Array, + IOArray, + STArray, + module Data.Ix, + module Data.ArrayBZ.Internals.IArray, + module Data.ArrayBZ.Internals.MArray, + ) where + +import Data.Ix +import Data.ArrayBZ.Internals.Boxed +import Data.ArrayBZ.Internals.IArray +import Data.ArrayBZ.Internals.MArray diff --git a/Data/ArrayBZ/Diff.hs b/Data/ArrayBZ/Diff.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Diff.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, + MultiParamTypeClasses #-} +{- | + Module : Data.ArrayBZ.Diff + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +Functional arrays with constant-time update. + +-} + +module Data.ArrayBZ.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.ArrayBZ.Internals.IArray" provides the interface + -- of diff arrays. They are instances of class 'IArray'. + module Data.ArrayBZ.Internals.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 Data.Ix + +import System.IO.Unsafe ( unsafePerformIO ) +import Control.Exception ( evaluate ) +import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, readMVar ) + +import Data.ArrayBZ.Internals.IArray +import Data.ArrayBZ.Internals.MArray +import Data.ArrayBZ.Boxed +import Data.ArrayBZ.Unboxed +import Data.HasDefaultValue +import Data.Unboxed + +------------------------------------------------------------------------ +-- 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 + +------------------------------------------------------------------------ +-- Instances. + +instance HasBounds a => HasBounds (IOToDiffArray a) where + bounds a = unsafePerformIO $ boundsDiffArray a + +instance IArray DiffArray e where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray1` ies + +instance (Unboxed e) => IArray DiffUArray e where + unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies + unsafeAt a i = unsafePerformIO $ a `readDiffArray` i + unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies + +------------------------------------------------------------------------ +-- Showing DiffArrays. + +instance (Ix i, Show i, Show e) => Show (DiffArray i e) where + showsPrec = showsIArray + +instance (Ix i, Show i, Show e, Unboxed e, HasDefaultValue e) => Show (DiffUArray i e) where + showsPrec = showsIArray + +-- --------------------------------------------------------------------------- +-- Comparing DiffArrays. + +instance (Ix i, Eq i, Eq e) => Eq (DiffArray i e) where + (==) = eqIArray + +instance (Ix i, Ord i, Ord e) => Ord (DiffArray i e) where + compare = cmpIArray + +instance (Ix i, Eq i, Eq e, Unboxed e, HasDefaultValue e) => Eq (DiffUArray i e) where + (==) = eqIArray + +instance (Ix i, Ord i, Ord e, Unboxed e, HasDefaultValue e) => Ord (DiffUArray i e) where + compare = cmpIArray + +------------------------------------------------------------------------ +-- Helper functions. + +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 :: (HasBounds a, Ix ix) + => IOToDiffArray a ix e + -> IO (ix,ix) +boundsDiffArray a = do + d <- readMVar (varDiffArray a) + case d of + Current a' -> return (bounds a') + Diff a' _ -> boundsDiffArray a' + +freezeDiffArray :: (MArray a e IO, Ix ix) + => a ix e + -> IO (IOToDiffArray a ix e) +freezeDiffArray a = do + lu <- getBounds a + a' <- newArray_ lu + sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize lu - 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 + lu <- getBounds a' + a'' <- newArray_ lu + sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize lu - 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/ArrayBZ/Dynamic.hs b/Data/ArrayBZ/Dynamic.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Dynamic.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE CPP, UndecidableInstances, FlexibleInstances, MultiParamTypeClasses #-} +{- | + Module : Data.ArrayBZ.Dynamic + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +Arrays with dynamically changed bounds in IO and ST monads. + +-} + +module Data.ArrayBZ.Dynamic ( + -- $info + -- * Type constructors + Dynamic, + DynamicIO, + DynamicIOArray, + DynamicIOUArray, + DynamicST, + DynamicSTArray, + DynamicSTUArray, + GrowBoundsF, + -- * Operations + newDynamicArray, + newDynamicArray_, + resizeDynamicArray, + -- * Array growing strategies + noGrow, + growMinimally, + growTwoTimes, + -- Reexported MArray interface + module Data.ArrayBZ.Internals.MArray + ) where + +import Data.Ref +import Data.ArrayBZ.Internals.MArray +import Data.ArrayBZ.IO +import Data.ArrayBZ.ST +#ifdef __GLASGOW_HASKELL__ +import GHC.Arr ( unsafeIndex ) +#endif +#ifdef __HUGS__ +import Hugs.Array ( unsafeIndex ) +#endif + +{- $info + +Array with dynamically changed bounds can be created from any mutable array +type by using type converter Dynamic. I have created synonyms for widely used +array constructors, for example "DynamicIOUArray Int Double". +Dynamic array supports the same MArray and HasMutableBounds interfaces as other +mutable arrays, but they don't support HasBounds interface. Dynamic array can be +resized explicitly by operation `resizeDynamicArray`. + +Dynamic array can also grow automatically when `writeArray` is used with index +that is out of current array bounds. For this to work, array should be created +using non-standard operations `newDynamicArray` or `newDynamicArray_`. The first +argument of these operations is "growing strategy", i.e. the function of type +`GrowBoundsF i`, other arguments are the same as for newArray/newArray_. The +predefined growing strategies include `noGrow` that disables automatic growing, +`growMinimally` that extends array only to include new index and `growTwoTimes` +that extend array at least 2 times each time it needs to grow. + +When array grows, either explicitly or automatically, new elements are +initialized with `init` value if this array was created by +newArray/newDynamicArray. + +-} + +-- --------------------------------------------------------------------------- +-- Types + +-- | Representation of dynamic array. Includes +-- * function to calculate new array bounds when it needs to grow +-- * optional value used for initializing new elements when array grows +-- * reference to current array contents +data Dynamic r a i e = Dynamic (GrowBoundsF i) (Maybe e) (r (a i e)) + +-- | Dynamic arrays in IO monad +type DynamicIO = Dynamic IORef +-- |Dynamic version of IOArray +type DynamicIOArray = DynamicIO IOArray +-- |Dynamic version of IOUArray +type DynamicIOUArray = DynamicIO IOUArray + +-- | Dynamic arrays in ST monad +type DynamicST s = Dynamic (STRef s) +-- |Dynamic version of STArray +type DynamicSTArray s = (DynamicST s) (STArray s) +-- |Dynamic version of STUArray +type DynamicSTUArray s = (DynamicST s) (STUArray s) + +-- | This type represents function that calculates new array bounds when it needs to grow +type GrowBoundsF i = (i,i) -> i -> (i,i) + +-- --------------------------------------------------------------------------- +-- Operations + +-- | Create new dynamic array with default value for new cells set to `init`. +-- `f` is a growing strategy and may be `noGrow`, `growMinimally` +-- or `growTwoTimes` +newDynamicArray f bounds init = do + arr <- newArray bounds init + a <- newRef arr + return (Dynamic f (Just init) a) + +-- | Create new dynamic array where all new cells will remain uninitialized. +-- `f` is a growing strategy and may be `noGrow`, `growMinimally` +-- or `growTwoTimes` +newDynamicArray_ f bounds = do + arr <- newArray_ bounds + a <- newRef arr + return (Dynamic f Nothing a) + +-- | Extend/shrink dynamic array to new bounds +resizeDynamicArray (Dynamic _ e a) newbounds = do + arr <- readRef a + bounds <- getBounds arr + newarr <- case e of + Just init -> newArray newbounds init + Nothing -> newArray_ newbounds + sequence_ [ readArray arr i >>= writeArray newarr i + | i <- range bounds, inRange newbounds i ] + writeRef a newarr + +-- --------------------------------------------------------------------------- +-- Instances + +instance (HasMutableBounds a m, Ref m r) => HasMutableBounds (Dynamic r a) m where + {-# INLINE getBounds #-} + getBounds (Dynamic _ _ a) = readRef a >>= getBounds + +instance (MArray a e m, Ref m r) => MArray (Dynamic r a) e m where + newArray_ = newDynamicArray_ noGrow + newArray = newDynamicArray noGrow + + {-# INLINE unsafeRead #-} + unsafeRead (Dynamic _ _ a) i = do arr <- readRef a + unsafeRead arr i + + {-# INLINE unsafeWrite #-} + unsafeWrite (Dynamic _ _ a) i e = do arr <- readRef a + unsafeWrite arr i e + + {-# INLINE writeArray #-} + writeArray dyn@(Dynamic _ _ a) i e = do + arr <- readRef a + bounds <- getBounds arr + if inRange bounds i + then unsafeWrite arr (unsafeIndex bounds i) e + else extendAndWrite dyn arr bounds i e + +-- Helper function used to make `writeArray` look as non-recursive function, +-- what is required for GHC's optimization +extendAndWrite dyn@(Dynamic extend _ a) arr bounds i e = do + resizeDynamicArray dyn (extend bounds i) + writeArray dyn i e + + +-- --------------------------------------------------------------------------- +-- Bounds growing functions, that can be used with newDynamicArray/newDynamicArray_ + +-- | No automatic growing at all. This "growing" method is compatible with any +-- bounds type +noGrow _ _ = error "Dynamic array: index out of bounds" + +-- | Grow minimally - only to include new index in array bounds. This growing +-- method is compatible with any bounds type +growMinimally (l,u) i | inRange (l,i) u = (l,i) + | inRange (i,u) l = (i,u) + | otherwise = error "can't compute new bounds for dynamic array" + +-- | Grow number of elements at least 2 times. This growing method is compatible +-- only with bounds belonging to class Num +growTwoTimes (l,u) i = if i + Stability : experimental + Portability: Hugs/GHC + +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.ArrayBZ.Unboxed" and "Data.ArrayBZ.Diff" modules. + +-} + +module Data.ArrayBZ.IArray ( + -- * Array classes + HasBounds, -- :: (* -> * -> *) -> class + 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 Data.Ix +import Data.ArrayBZ.Internals.IArray +import Data.ArrayBZ.Internals.Boxed (Array) diff --git a/Data/ArrayBZ/IO.hs b/Data/ArrayBZ/IO.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/IO.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE CPP, UnliftedFFITypes #-} +{-# INCLUDE "HsBase.hs" #-} +{- | + Module : Data.ArrayBZ.IO + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +Mutable boxed and unboxed arrays in the IO monad. +-} + +module Data.ArrayBZ.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.ArrayBZ.MArray, + + -- * Doing I\/O with @IOUArray@s + hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int + hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO () + ) where + +import Data.Word + +import Data.ArrayBZ.MArray +import Data.ArrayBZ.Internals.Boxed ( IOArray ) +import Data.ArrayBZ.Internals.Unboxed + +#ifdef __GLASGOW_HASKELL__ +import Foreign +import Foreign.C + +import GHC.IOBase hiding (IOArray) +import GHC.Handle +import GHC.Unboxed + +-- --------------------------------------------------------------------------- +-- 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 (UMA l u (MUVec 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 r (fromIntegral avail) + writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } + return avail + else do + memcpy_ba_baoff ptr raw 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 (UMA l u (MUVec 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 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 -> Int -> RawBuffer -> CSize -> IO (Ptr ()) +foreign import ccall unsafe "__hscore_memcpy_src_off" + memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> 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__ */ +import Data.Char +import System.IO +import System.IO.Error +import Data.ArrayBZ.Internals.MArray + +hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int +hGetArray handle arr count + | count < 0 || count > rangeSize (bounds arr) + = illegalBufferSize handle "hGetArray" count + | otherwise = 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 + | count < 0 || count > rangeSize (bounds arr) + = illegalBufferSize handle "hPutArray" count + | otherwise = 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/ArrayBZ/Internals/Boxed.hs b/Data/ArrayBZ/Internals/Boxed.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Internals/Boxed.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} +{- | + Module : Data.ArrayBZ.Internals.Boxed + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +Boxed arrays + +-} + +module Data.ArrayBZ.Internals.Boxed +#ifdef __HUGS__ + ( -- * Types + Array, + IOArray, + STArray, + + -- * Freeze/thaw operations + freezeIOArray, + thawIOArray, + unsafeFreezeIOArray, + freezeSTArray, + thawSTArray, + unsafeFreezeSTArray, + ) +#endif + where + +import Control.Monad.ST ( ST, runST ) +import Control.Monad.ST.Lazy ( strictToLazyST ) +import qualified Control.Monad.ST.Lazy as Lazy (ST) +import Data.Ix +import Data.Typeable +#include "Typeable.h" + +import Data.ArrayBZ.Internals.IArray +import Data.ArrayBZ.Internals.MArray + +#ifdef __HUGS__ +-- --------------------------------------------------------------------------- +-- Hugs primitives are higher-level than GHC/NHC's +-- --------------------------------------------------------------------------- + +import Hugs.Array as Arr +import Hugs.IOArray +import Hugs.ST + +----------------------------------------------------------------------------- +-- Normal polymorphic arrays + +instance HasBounds Array where + bounds = Arr.bounds + +instance IArray Array e where + unsafeArray = Arr.unsafeArray + unsafeAt = Arr.unsafeAt + unsafeReplace = Arr.unsafeReplace + unsafeAccum = Arr.unsafeAccum + unsafeAccumArray = Arr.unsafeAccumArray + +----------------------------------------------------------------------------- +-- | Instance declarations for 'IOArray's + +instance HasBounds IOArray where + bounds = boundsIOArray + +instance HasMutableBounds IOArray IO where + getBounds = return . boundsIOArray + +instance MArray IOArray e IO where + newArray = newIOArray + unsafeRead = unsafeReadIOArray + unsafeWrite = unsafeWriteIOArray + +----------------------------------------------------------------------------- +-- Polymorphic non-strict mutable arrays (ST monad) + +instance HasBounds (STArray s) where + bounds = boundsSTArray + +instance HasMutableBounds (STArray s) (ST s) where + getBounds = return . boundsSTArray + +instance MArray (STArray s) e (ST s) where + newArray = newSTArray + unsafeRead = unsafeReadSTArray + unsafeWrite = unsafeWriteSTArray + +#else +-- --------------------------------------------------------------------------- +-- Non-Hugs implementation +-- --------------------------------------------------------------------------- + +import Control.Monad.STorIO +import GHC.ArrBZ + +-- --------------------------------------------------------------------------- +-- | Boxed mutable arrays + +data BoxedMutableArray s i e = BMA !i !i !(MVec s e) + +instance HasBounds (BoxedMutableArray s) where + {-# INLINE bounds #-} + bounds (BMA l u _) = (l,u) + +instance (STorIO m s) => HasMutableBounds (BoxedMutableArray s) m where + {-# INLINE getBounds #-} + getBounds (BMA l u _) = return (l,u) + +instance (STorIO m s) => MArray (BoxedMutableArray s) e m where + newArray (l,u) init = do arr <- allocBoxed (rangeSize (l,u)) init + return (BMA l u arr) + {-# INLINE unsafeRead #-} + unsafeRead (BMA _ _ arr) index = readBoxed arr index + {-# INLINE unsafeWrite #-} + unsafeWrite (BMA _ _ arr) index = writeBoxed arr index + +-- --------------------------------------------------------------------------- +-- | Boxed mutable arrays in ST monad + +type STArray = BoxedMutableArray + +-- --------------------------------------------------------------------------- +-- STArray also works in Lazy ST monad + +instance MArray (STArray s) e (Lazy.ST s) where + {-# INLINE newArray #-} + newArray (l,u) init = strictToLazyST (newArray (l,u) init) + {-# INLINE unsafeRead #-} + unsafeRead arr i = strictToLazyST (unsafeRead arr i) + {-# INLINE unsafeWrite #-} + unsafeWrite arr i e = strictToLazyST (unsafeWrite arr i e) + +-- --------------------------------------------------------------------------- +-- | Boxed mutable arrays in IO monad + +type IOArray = IOSpecific3 BoxedMutableArray + +-- --------------------------------------------------------------------------- +-- | Boxed immutable arrays + +data Array i e = BA !i !i !(Vec e) + +instance HasBounds Array where + {-# INLINE bounds #-} + bounds (BA l u _) = (l,u) + +instance IArray Array e where + {-# INLINE unsafeArray #-} + -- Create new array filled with (i,e) values + unsafeArray lu ies = runST (withNewArray lu arrEleBottom (doReplace ies)) + {-# INLINE unsafeAt #-} + unsafeAt (BA _ _ arr) index = indexBoxed arr index + {-# INLINE unsafeReplace #-} + -- Make a copy of array and perform (i,e) replacements + unsafeReplace arr ies = runST (withArrayCopy arr (doReplace ies)) + {-# INLINE unsafeAccum #-} + -- Make a copy of array and perform (i,e) accumulation in new array + unsafeAccum f arr ies = runST (withArrayCopy arr (doAccum f ies)) + {-# INLINE unsafeAccumArray #-} + -- Create new array accumulating (i,e) values + unsafeAccumArray f init lu ies = runST (withNewArray lu init (doAccum f ies)) + + +-- Implementation helper functions ------------- + +-- Create new array and perform given action on it before freezing +withNewArray lu init action = do + marr <- newArray lu init + action marr + unsafeFreezeBA marr + +-- Make a copy of array and perform given action on it before freezing +withArrayCopy arr action = do + marr <- thawBA arr + action marr + unsafeFreezeBA marr + +-- Perform (i,e) replaces in mutable array +doReplace ies marr = do + sequence_ [unsafeWrite marr i e | (i, e) <- ies] + +-- Accumulate (i,e) values in mutable array +doAccum f ies marr = do + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] + +-- Mutable->immutable array conversion which takes a copy of contents +freezeBA ua@(BMA l u marr) = do + arr <- freezeBoxed marr (sizeOfBA ua) arrEleBottom + return (BA l u arr) + +-- Immutable->mutable array conversion which takes a copy of contents +thawBA ua@(BA l u arr) = do + marr <- thawBoxed arr (sizeOfBA ua) arrEleBottom + return (BMA l u marr) + +-- On-the-place mutable->immutable array conversion +unsafeFreezeBA (BMA l u marr) = do + arr <- unsafeFreezeBoxed marr + return (BA l u arr) + +-- On-the-place immutable->mutable array conversion +unsafeThawBA ua@(BA l u arr) = do + marr <- unsafeThawBoxed arr + return (BMA l u marr) + +-- | Number of array elements +sizeOfBA arr = rangeSize (bounds arr) + +-- --------------------------------------------------------------------------- +-- | Freeze/thaw rules for IOArray + +freezeIOArray :: (Ix i) => IOArray i e -> IO (Array i e) +thawIOArray :: (Ix i) => Array i e -> IO (IOArray i e) +unsafeFreezeIOArray :: (Ix i) => IOArray i e -> IO (Array i e) +unsafeThawIOArray :: (Ix i) => Array i e -> IO (IOArray i e) + +freezeIOArray = freezeBA +thawIOArray = thawBA +unsafeFreezeIOArray = unsafeFreezeBA +unsafeThawIOArray = unsafeThawBA + +{-# RULES +"freeze/IOArray" freeze = freezeIOArray +"thaw/IOArray" thaw = thawIOArray +"unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray +"unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray + #-} + +-- --------------------------------------------------------------------------- +-- | Freeze/thaw rules for STArray + +freezeSTArray :: (Ix i) => STArray s i e -> ST s (Array i e) +thawSTArray :: (Ix i) => Array i e -> ST s (STArray s i e) +unsafeFreezeSTArray :: (Ix i) => STArray s i e -> ST s (Array i e) +unsafeThawSTArray :: (Ix i) => Array i e -> ST s (STArray s i e) + +freezeSTArray = freezeBA +thawSTArray = thawBA +unsafeFreezeSTArray = unsafeFreezeBA +unsafeThawSTArray = unsafeThawBA + +{-# RULES +"freeze/STArray" freeze = freezeSTArray +"thaw/STArray" thaw = thawSTArray +"unsafeFreeze/STArray" unsafeFreeze = unsafeFreezeSTArray +"unsafeThaw/STArray" unsafeThaw = unsafeThawSTArray + #-} + +-- --------------------------------------------------------------------------- +-- | Instances + +instance (Ix i, Show i, Show e) => Show (Array i e) where + showsPrec = showsIArray + +instance (Ix i, Eq i, Eq e) => Eq (Array i e) where + (==) = eqIArray + +instance (Ix i, Ord i, Ord e) => Ord (Array i e) where + compare = cmpIArray + +#endif + + +INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray") + +INSTANCE_TYPEABLE3(STArray,stArrayTc,"STArray") + diff --git a/Data/ArrayBZ/Internals/IArray.hs b/Data/ArrayBZ/Internals/IArray.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Internals/IArray.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses #-} +{- | + Module : Data.ArrayBZ.Internals.IArray + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +Immutable arrays: class, general algorithms and Show/Ord/Eq implementations + +-} + +module Data.ArrayBZ.Internals.IArray where + +import Control.Monad.ST ( ST, runST ) +import Data.Ix +#ifdef __GLASGOW_HASKELL__ +import GHC.Arr ( unsafeIndex ) +#endif +#ifdef __HUGS__ +import Hugs.Array ( unsafeIndex ) +#endif + +----------------------------------------------------------------------------- +-- Class of immutable arrays + +-- | Class of array types with immutable bounds +-- (even if the array elements are mutable). +class HasBounds a where + -- | Extracts the bounds of an array + bounds :: Ix i => a i e -> (i,i) + +{- | 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 HasBounds a => IArray a e where + 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 + +----------------------------------------------------------------------------- +-- Algorithms on immutable arrays + +{-# 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 (!) #-} +-- | 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 :: (HasBounds a, 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)] + +----------------------------------------------------------------------------- +-- Implementation of Show instance + +{-# SPECIALISE + showsIArray :: (IArray a e, Ix i, Show i, Show e) => + Int -> a 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) + +----------------------------------------------------------------------------- +-- Implementation of Eq/Ord instances + +{-# INLINE eqIArray #-} +eqIArray :: (IArray a e, Ix i, Eq e) => a i e -> a i e -> Bool +eqIArray arr1 arr2 = + case bounds arr1 of { (l1,u1) -> + case bounds arr2 of { (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 cmpIArray #-} +cmpIArray :: (IArray a e, Ix i, Ord e) => a i e -> a i e -> Ordering +cmpIArray arr1 arr2 = compare (assocs arr1) (assocs arr2) + +{-# INLINE cmpIntIArray #-} +cmpIntIArray :: (IArray a e, Ord e) => a Int e -> a Int e -> Ordering +cmpIntIArray arr1 arr2 = + case bounds arr1 of { (l1,u1) -> + case bounds arr2 of { (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 "cmpIArray/Int" cmpIArray = cmpIntIArray #-} + diff --git a/Data/ArrayBZ/Internals/MArray.hs b/Data/ArrayBZ/Internals/MArray.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Internals/MArray.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses #-} +{- | + Module : Data.ArrayBZ.Internals.MArray + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +Mutable arrays: class and general algorithms +Freeze/Thaw: mutable<->immutable arrays conversion + +-} + +module Data.ArrayBZ.Internals.MArray where + +import Control.Monad.ST ( ST, runST ) +import Data.Ix +#ifdef __GLASGOW_HASKELL__ +import GHC.Arr ( unsafeIndex ) +#endif +#ifdef __HUGS__ +import Hugs.Array ( unsafeIndex ) +#endif + +import Data.ArrayBZ.Internals.IArray + +----------------------------------------------------------------------------- +-- Mutable arrays + +-- | Value used to initialize undefined array elements +{-# NOINLINE arrEleBottom #-} +arrEleBottom :: a +arrEleBottom = error "MArray: undefined array element" + +-- | Class of array types with mutable bounds +class (Monad m) => HasMutableBounds a m where + -- | Get the current bounds of an array + getBounds :: Ix i => a i e -> m (i,i) + +{-| 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, HasMutableBounds a m) => MArray a e m where + + -- | 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 undefined. + newArray_ :: 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 () + + readArray :: Ix i => a i e -> i -> m e + writeArray :: Ix i => a i e -> i -> 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 <- newArray_ (l,u) + sequence_ [unsafeWrite marr i init | i <- [0 .. rangeSize (l,u) - 1]] + return marr + + newArray_ (l,u) = newArray (l,u) arrEleBottom + + -- newArray takes an initialiser which all elements of + -- the newly created array are initialised to. newArray_ takes + -- no initialiser, it is assumed that the array is initialised with + -- "undefined" values. + + -- why not omit newArray_? 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 readArray #-} + -- | Read an element from a mutable array + readArray marr i = do + (l,u) <- getBounds marr + unsafeRead marr (index (l,u) i) + + {-# INLINE writeArray #-} + -- | Write an element in a mutable array + writeArray marr i e = do + (l,u) <- getBounds marr + unsafeWrite marr (index (l,u) i) e + + +----------------------------------------------------------------------------- +-- Algorithms on mutable arrays + +{-# 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 getIndices #-} +-- | Return a list of all the indexes of a mutable array +getIndices :: (MArray a e m, Ix i) => a i e -> m [i] +getIndices marr = do + (l,u) <- getBounds marr + return (range (l,u)) + +{-# 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' + +----------------------------------------------------------------------------- +-- 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) + +-- 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 + +----------------------------------------------------------------------------- +-- 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 + +-- 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 + diff --git a/Data/ArrayBZ/Internals/Unboxed.hs b/Data/ArrayBZ/Internals/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Internals/Unboxed.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances, + MultiParamTypeClasses #-} +{- | + Module : Data.ArrayBZ.Internals.Unboxed + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +Unboxed arrays + +Based on the idea of Oleg Kiselyov + (see http://www.haskell.org/pipermail/haskell-cafe/2004-July/006400.html) +-} + +module Data.ArrayBZ.Internals.Unboxed where + +import Control.Monad.ST (ST, runST) +import Control.Monad.ST.Lazy ( strictToLazyST ) +import qualified Control.Monad.ST.Lazy as Lazy (ST) +import Data.Ix +import Data.Typeable +#include "Typeable.h" + +import Control.Monad.STorIO +import Data.ArrayBZ.Internals.IArray +import Data.ArrayBZ.Internals.MArray +import Data.HasDefaultValue +import Data.Unboxed + +-- --------------------------------------------------------------------------- +-- | Unboxed mutable arrays + +data UnboxedMutableArray s i e = UMA !i !i !(MUVec s e) + +instance HasBounds (UnboxedMutableArray s) where + {-# INLINE bounds #-} + bounds (UMA l u _) = (l,u) + +instance (STorIO m s) => HasMutableBounds (UnboxedMutableArray s) m where + {-# INLINE getBounds #-} + getBounds (UMA l u _) = return (l,u) + +instance (STorIO m s, Unboxed e) => MArray (UnboxedMutableArray s) e m where + newArray_ (l,u) = do arr <- allocUnboxed (rangeSize (l,u)) + return (UMA l u arr) + {-# INLINE unsafeRead #-} + unsafeRead (UMA _ _ arr) index = readUnboxed arr index + {-# INLINE unsafeWrite #-} + unsafeWrite (UMA _ _ arr) index = writeUnboxed arr index + +-- --------------------------------------------------------------------------- +-- | Unboxed mutable arrays in ST monad + +type STUArray = UnboxedMutableArray + +INSTANCE_TYPEABLE3(STUArray,stUArrayTc,"STUArray") + +-- --------------------------------------------------------------------------- +-- STUArray also works in Lazy ST monad + +instance (Unboxed e) => MArray (STUArray s) e (Lazy.ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = strictToLazyST (newArray_ (l,u)) + {-# INLINE unsafeRead #-} + unsafeRead arr i = strictToLazyST (unsafeRead arr i) + {-# INLINE unsafeWrite #-} + unsafeWrite arr i e = strictToLazyST (unsafeWrite arr i e) + +-- --------------------------------------------------------------------------- +-- | Unboxed mutable arrays in IO monad + +type IOUArray = IOSpecific3 UnboxedMutableArray + +INSTANCE_TYPEABLE2(IOUArray,iOUArrayTc,"IOUArray") + +-- --------------------------------------------------------------------------- +-- | Unboxed arrays + +data UArray i e = UA !i !i !(UVec e) + +INSTANCE_TYPEABLE2(UArray,uArrayTc,"UArray") + +instance HasBounds UArray where + {-# INLINE bounds #-} + bounds (UA l u _) = (l,u) + +instance (Unboxed e, HasDefaultValue e) => IArray UArray e where + {-# INLINE unsafeArray #-} + -- Create new array filled with (i,e) values + unsafeArray lu ies = runST (withNewArray lu defaultValue (doReplace ies)) + {-# INLINE unsafeAt #-} + unsafeAt (UA _ _ arr) index = indexUnboxed arr index + {-# INLINE unsafeReplace #-} + -- Make a copy of array and perform (i,e) replacements + unsafeReplace arr ies = runST (withArrayCopy arr (doReplace ies)) + {-# INLINE unsafeAccum #-} + -- Make a copy of array and perform (i,e) accumulation in new array + unsafeAccum f arr ies = runST (withArrayCopy arr (doAccum f ies)) + {-# INLINE unsafeAccumArray #-} + -- Create new array accumulating (i,e) values + unsafeAccumArray f init lu ies = runST (withNewArray lu init (doAccum f ies)) + + +-- Implementation helper functions ------------- + +-- Create new array and perform given action on it before freezing +withNewArray lu init action = do + marr <- newArray lu init + action marr + unsafeFreezeUA marr + +-- Make a copy of array and perform given action on it before freezing +withArrayCopy arr action = do + marr <- thawUA arr + action marr + unsafeFreezeUA marr + +-- Perform (i,e) replaces in mutable array +doReplace ies marr = do + sequence_ [unsafeWrite marr i e | (i, e) <- ies] + +-- Accumulate (i,e) values in mutable array +doAccum f ies marr = do + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] + +-- Mutable->immutable array conversion which takes a copy of contents +freezeUA uma@(UMA l u marr) = do + arr <- freezeUnboxed marr (sizeOfUMA uma) + return (UA l u arr) + +-- Immutable->mutable array conversion which takes a copy of contents +thawUA ua@(UA l u arr) = do + marr <- thawUnboxed arr (sizeOfUA ua) + return (UMA l u marr) + +-- On-the-place mutable->immutable array conversion +unsafeFreezeUA (UMA l u marr) = do + arr <- unsafeFreezeUnboxed marr + return (UA l u arr) + +-- On-the-place immutable->mutable array conversion +unsafeThawUA ua@(UA l u arr) = do + marr <- unsafeThawUnboxed arr + return (UMA l u marr) + +-- | Array size in bytes +sizeOfUA :: forall i e. (Ix i, Unboxed e) => UArray i e -> Int +sizeOfUA arr = + rangeSize (bounds arr) * sizeOfUnboxed (undefined :: e) + +sizeOfUMA :: forall i e s. (Ix i, Unboxed e) => UnboxedMutableArray s i e -> Int +sizeOfUMA marr = + rangeSize (bounds marr) * sizeOfUnboxed (undefined :: e) + +-- --------------------------------------------------------------------------- +-- | Freeze/thaw rules for IOUArray + +freezeIOUArray :: (Unboxed e, HasDefaultValue e, Ix i) => IOUArray i e -> IO (UArray i e) +thawIOUArray :: (Unboxed e, HasDefaultValue e, Ix i) => UArray i e -> IO (IOUArray i e) +unsafeFreezeIOUArray :: (Unboxed e, HasDefaultValue e, Ix i) => IOUArray i e -> IO (UArray i e) +unsafeThawIOUArray :: (Unboxed e, HasDefaultValue e, Ix i) => UArray i e -> IO (IOUArray i e) + +freezeIOUArray = freezeUA +thawIOUArray = thawUA +unsafeFreezeIOUArray = unsafeFreezeUA +unsafeThawIOUArray = unsafeThawUA + +{-# RULES +"freeze/IOUArray" forall (x :: (forall s e i . (Unboxed e, HasDefaultValue e) => IOUArray i e)) . freeze x = freezeIOUArray x +"thaw/IOUArray" forall (x :: (forall e i . (Unboxed e, HasDefaultValue e) => UArray i e)) . thaw x = thawIOUArray x +"unsafeFreeze/IOUArray" forall (x :: (forall s e i . (Unboxed e, HasDefaultValue e) => IOUArray i e)) . unsafeFreeze x = unsafeFreezeIOUArray x +"unsafeThaw/IOUArray" forall (x :: (forall e i . (Unboxed e, HasDefaultValue e) => UArray i e)) . unsafeThaw x = unsafeThawIOUArray x + #-} + +-- --------------------------------------------------------------------------- +-- | Freeze/thaw rules for STUArray + +freezeSTUArray :: (Unboxed e, HasDefaultValue e, Ix i) => STUArray s i e -> ST s (UArray i e) +thawSTUArray :: (Unboxed e, HasDefaultValue e, Ix i) => UArray i e -> ST s (STUArray s i e) +unsafeFreezeSTUArray :: (Unboxed e, HasDefaultValue e, Ix i) => STUArray s i e -> ST s (UArray i e) +unsafeThawSTUArray :: (Unboxed e, HasDefaultValue e, Ix i) => UArray i e -> ST s (STUArray s i e) + +freezeSTUArray = freezeUA +thawSTUArray = thawUA +unsafeFreezeSTUArray = unsafeFreezeUA +unsafeThawSTUArray = unsafeThawUA + +{-# RULES +"freeze/STUArray" forall (x :: (forall s e i . (Unboxed e, HasDefaultValue e) => STUArray s i e)) . freeze x = freezeSTUArray x +"thaw/STUArray" forall (x :: (forall e i . (Unboxed e, HasDefaultValue e) => UArray i e)) . thaw x = thawSTUArray x +"unsafeFreeze/STUArray" forall (x :: (forall s e i . (Unboxed e, HasDefaultValue e) => STUArray s i e)) . unsafeFreeze x = unsafeFreezeSTUArray x +"unsafeThaw/STUArray" forall (x :: (forall e i . (Unboxed e, HasDefaultValue e) => UArray i e)) . unsafeThaw x = unsafeThawSTUArray x + #-} + +-- --------------------------------------------------------------------------- +-- | Casts to arrays with different element type + +-- | Casts an 'UArray' with one element type into 'UArray' with a +-- different element type. All the elements of the resulting array +-- are undefined (unless you know what you\'re doing...). +-- Upper array bound is recalculated according to elements size, +-- for example UArray (1,2) Word32 -> UArray (1,8) Word8 +castUArray :: forall i e e'. (Ix i, Enum i, Unboxed e, Unboxed e') + => UArray i e -> UArray i e' +castUArray (UA l u vec) = + (UA l u' (castUnboxed vec)) + where u' = toEnum (fromEnum l - 1 + newSize) + newSize = rangeSize (l,u) * sizeOfUnboxed (undefined::e) + `div` sizeOfUnboxed (undefined::e') + +-- | Casts an 'IOUArray' with one element type into 'IOUArray' with a different +-- element type (upper bound is recalculated). +castIOUArray :: forall i e e'. (Ix i, Enum i, Unboxed e, Unboxed e') + => IOUArray i e -> IOUArray i e' +castIOUArray (UMA l u mvec) = + (UMA l u' (castMUnboxed mvec)) + where u' = toEnum (fromEnum l - 1 + newSize) + newSize = rangeSize (l,u) * sizeOfUnboxed (undefined::e) + `div` sizeOfUnboxed (undefined::e') + +-- | Casts an 'STUArray' with one element type into 'STUArray' with a different +-- element type (upper bound is recalculated). +castSTUArray :: forall i e e' s. (Ix i, Enum i, Unboxed e, Unboxed e') + => STUArray s i e -> STUArray s i e' +castSTUArray (UMA l u mvec) = + (UMA l u' (castMUnboxed mvec)) + where u' = toEnum (fromEnum l - 1 + newSize) + newSize = rangeSize (l,u) * sizeOfUnboxed (undefined::e) + `div` sizeOfUnboxed (undefined::e') + +-- --------------------------------------------------------------------------- +-- | Instances + +instance (Ix i, Show i, Show e, Unboxed e, HasDefaultValue e) => Show (UArray i e) where + showsPrec = showsIArray + +instance (Ix i, Eq i, Eq e, Unboxed e, HasDefaultValue e) => Eq (UArray i e) where + (==) = eqIArray + +instance (Ix i, Ord i, Ord e, Unboxed e, HasDefaultValue e) => Ord (UArray i e) where + compare = cmpIArray + diff --git a/Data/ArrayBZ/Internals/readme.txt b/Data/ArrayBZ/Internals/readme.txt new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Internals/readme.txt @@ -0,0 +1,21 @@ +Module hierarchy: + +Module Data.ArrayBZ.Internals.MArray defines class MArray and general algorithms +working with any instance of this class + +Module Data.ArrayBZ.Internals.IArray defines class IArray and general algorithms +working with any instance of this class. In addition, it defines functions +used to implement Show, Eq and Ord instances (these instances cannot be +defined here due to the "overlapped instances" problem) + +Module Data.ArrayBZ.Internals.Boxed imports modules IArray and MArray, and then +defines Array/IOArray/STArray. Module Data.ArrayBZ.Internals.Unboxed also imports +modules IArray and MArray, and then defines UArray/IOUArray/STUArray + +Modules Data.ArrayBZ.Boxed and Data.ArrayBZ.Unboxed reexports corresponding +internal modules together with IArray and MArray modules, what gives their users +ability to use all boxed (unboxed) arrays together with all general algorithms +defined for IArray and MArray classes + +Also, file unused.hs contains parts of original code that's still not used in +new one diff --git a/Data/ArrayBZ/Internals/unused.hs b/Data/ArrayBZ/Internals/unused.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Internals/unused.hs @@ -0,0 +1,137 @@ + +This file contains remaining code from old Data.Array.* library that is still +unused in new code. It mainly consists of speed tricks (that may be even not +needed in new code). + +------------------------------------------------------------------------------------------ +class HasBounds a => IArray a e where + 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 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 + +------------------------------------------------------------------------------------------ +instance MArray (STArray s) e (Lazy.ST s) where + {-# 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) diff --git a/Data/ArrayBZ/MArray.hs b/Data/ArrayBZ/MArray.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/MArray.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Data.ArrayBZ.MArray + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +An overloaded interface to mutable arrays. For array types which can be +used with this interface, see "Data.ArrayBZ.IO", "Data.ArrayBZ.ST", +and "Data.ArrayBZ.Storable". + +-} + +module Data.ArrayBZ.MArray ( + -- * Class of mutable array types + MArray, -- :: (* -> * -> *) -> * -> (* -> *) -> class + + -- * Class of array types with bounds + HasBounds, -- :: (* -> * -> *) -> class + + -- * Class of array types with mutable bounds + HasMutableBounds, -- :: (* -> * -> *) -> (* -> *) -> 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 + bounds, -- :: (HasBounds a, Ix i) => a i e -> (i,i) + indices, -- :: (HasBounds a, Ix i) => a i e -> [i] + getBounds, -- :: (HasMutableBounds a, Ix i) => a i e -> m (i,i) + getIndices, -- :: (HasMutableBounds a, Ix i) => a i e -> m [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 Data.Ix + +import Data.ArrayBZ.Internals.IArray +import Data.ArrayBZ.Internals.MArray diff --git a/Data/ArrayBZ/ST.hs b/Data/ArrayBZ/ST.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/ST.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RankNTypes, TypeOperators #-} +{- | + Module : Data.ArrayBZ.ST + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +Mutable boxed and unboxed arrays in the 'Control.Monad.ST.ST' monad. + +-} + +module Data.ArrayBZ.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.ArrayBZ.MArray, + ) where + +import Control.Monad.ST ( ST, runST ) + +import Data.HasDefaultValue +import Data.Unboxed +import Data.ArrayBZ.MArray +import Data.ArrayBZ.Internals.Boxed +import Data.ArrayBZ.Internals.Unboxed + +-- | 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 :: (Unboxed e, HasDefaultValue e, Ix i) + => (forall s . ST s (STUArray s i e)) + -> UArray i e +runSTUArray st = runST (st >>= unsafeFreezeSTUArray) + diff --git a/Data/ArrayBZ/Storable.hs b/Data/ArrayBZ/Storable.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Storable.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{- | + Module : Data.ArrayBZ.Storable + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +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.ArrayBZ.IO.IOUArray' but slower. +Its advantage is that it's compatible with C. + +-} + +module Data.ArrayBZ.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.ArrayBZ.Internals.MArray" provides the interface of storable arrays. + -- They are instances of class 'MArray' (with the 'IO' monad). + module Data.ArrayBZ.Internals.MArray, + + -- * Accessing the pointer to the array contents + withStorableArray, -- :: StorableArray i e -> (Ptr e -> IO a) -> IO a + + touchStorableArray, -- :: StorableArray i e -> IO () + + -- * Casting ForeignPtr to StorableArray + unsafeForeignPtrToStorableArray + ) + where + +import Data.Ix +import Foreign hiding (newArray) + +import Data.ArrayBZ.Internals.IArray +import Data.ArrayBZ.Internals.MArray + +-- --------------------------------------------------------------------------- + +-- |The array type +data StorableArray i e = StorableArray !i !i !(ForeignPtr e) + +instance HasBounds StorableArray where + {-# INLINE bounds #-} + bounds (StorableArray l u _) = (l,u) + +instance HasMutableBounds StorableArray IO where + {-# INLINE getBounds #-} + getBounds (StorableArray l u _) = return (l,u) + +instance Storable e => MArray StorableArray e IO where + {-# INLINE newArray #-} + 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) + + newArray_ (l,u) = do + fp <- mallocForeignPtrArray (rangeSize (l,u)) + return (StorableArray l u fp) + + {-# INLINE unsafeRead #-} + unsafeRead (StorableArray _ _ fp) i = + withForeignPtr fp $ \a -> peekElemOff a i + + {-# INLINE unsafeWrite #-} + unsafeWrite (StorableArray _ _ fp) i e = + withForeignPtr fp $ \a -> pokeElemOff a i e + + +{-# INLINE withStorableArray #-} +-- |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/ArrayBZ/Unboxed.hs b/Data/ArrayBZ/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Data/ArrayBZ/Unboxed.hs @@ -0,0 +1,27 @@ +{- | + Module : Data.ArrayBZ.Unboxed + Copyright : (c) The University of Glasgow 2001 & (c) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +Unboxed arrays + +-} + +module Data.ArrayBZ.Unboxed ( + UArray, + IOUArray, + STUArray, + castUArray, + castIOUArray, + castSTUArray, + module Data.ArrayBZ.Internals.IArray, + module Data.ArrayBZ.Internals.MArray, + ) where + +import Data.ArrayBZ.Internals.Unboxed +import Data.ArrayBZ.Internals.IArray +import Data.ArrayBZ.Internals.MArray diff --git a/Data/HasDefaultValue.hs b/Data/HasDefaultValue.hs new file mode 100644 --- /dev/null +++ b/Data/HasDefaultValue.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Data.HasDefaultValue + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: portable + +Class 'HasDefaultValue' allows to declare type's default value + +-} + +module Data.HasDefaultValue ( + HasDefaultValue(..), + ) +where + +import Data.Int +import Data.Word +import Foreign.Ptr +import Foreign.StablePtr + +-- --------------------------------------------------------------------------- +-- | Types that has default value + +class HasDefaultValue a where + defaultValue :: a + +instance HasDefaultValue Bool where defaultValue = False +instance HasDefaultValue Char where defaultValue = '\0' +instance HasDefaultValue Int where defaultValue = 0 +instance HasDefaultValue Int8 where defaultValue = 0 +instance HasDefaultValue Int16 where defaultValue = 0 +instance HasDefaultValue Int32 where defaultValue = 0 +instance HasDefaultValue Int64 where defaultValue = 0 +#if !defined(__HUGS__) || defined(__HUGS_VERSION__) +-- don't define this for Hugs2003 +instance HasDefaultValue Word where defaultValue = 0 +#endif +instance HasDefaultValue Word8 where defaultValue = 0 +instance HasDefaultValue Word16 where defaultValue = 0 +instance HasDefaultValue Word32 where defaultValue = 0 +instance HasDefaultValue Word64 where defaultValue = 0 +instance HasDefaultValue Float where defaultValue = 0 +instance HasDefaultValue Double where defaultValue = 0 +instance HasDefaultValue (Ptr a) where defaultValue = nullPtr +instance HasDefaultValue (FunPtr a) where defaultValue = nullFunPtr +instance HasDefaultValue (StablePtr a) where defaultValue = castPtrToStablePtr nullPtr + diff --git a/Data/Ref.hs b/Data/Ref.hs new file mode 100644 --- /dev/null +++ b/Data/Ref.hs @@ -0,0 +1,24 @@ +{- | + Module : Data.Ref + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +References (mutable vars) + +-} + +module Data.Ref ( + module Data.IORef, + module Data.STRef, + module Data.Ref.Unboxed, + module Data.Ref.Universal, + ) where + +import Data.IORef +import Data.STRef +import Data.Ref.Unboxed +import Data.Ref.Universal diff --git a/Data/Ref/LazyST.hs b/Data/Ref/LazyST.hs new file mode 100644 --- /dev/null +++ b/Data/Ref/LazyST.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Data.Ref.LazyST + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +Mutable boxed and unboxed references in the lazy ST monad. + +-} + +module Data.Ref.LazyST ( + -- * STRefs + STRef, -- abstract, instance Eq + newSTRef, -- :: a -> ST s (STRef s a) + readSTRef, -- :: STRef s a -> ST s a + writeSTRef, -- :: STRef s a -> a -> ST s () + modifySTRef, -- :: STRef s a -> (a -> a) -> ST s () + + -- * STURefs + ST.STURef, -- abstract, instance Eq + newSTURef, -- :: a -> ST s (STURef s a) + readSTURef, -- :: STURef s a -> ST s a + writeSTURef, -- :: STURef s a -> a -> ST s () + modifySTURef -- :: STURef s a -> (a -> a) -> ST s () + ) where + +import Control.Monad.ST.Lazy +import Data.STRef.Lazy +import qualified Data.Ref.Unboxed as ST +import Data.Unboxed + +newSTURef :: (Unboxed a) => a -> ST s (ST.STURef s a) +readSTURef :: (Unboxed a) => ST.STURef s a -> ST s a +writeSTURef :: (Unboxed a) => ST.STURef s a -> a -> ST s () +modifySTURef :: (Unboxed a) => ST.STURef s a -> (a -> a) -> ST s () + +newSTURef = strictToLazyST . ST.newSTURef +readSTURef = strictToLazyST . ST.readSTURef +writeSTURef r a = strictToLazyST (ST.writeSTURef r a) +modifySTURef r f = strictToLazyST (ST.modifySTURef r f) + diff --git a/Data/Ref/Unboxed.hs b/Data/Ref/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Data/Ref/Unboxed.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Data.Ref.Unboxed + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC/Hugs + +Unboxed references + +Based on the idea of Oleg Kiselyov + (see http://www.haskell.org/pipermail/haskell-cafe/2004-July/006400.html) +-} + +module Data.Ref.Unboxed where + +import Control.Monad.ST (ST) +import Data.Typeable +#include "Typeable.h" + +import Control.Monad.STorIO +import Data.Unboxed + +-- ----------------------------------------------------------------------------- +-- | Unboxed references in IO monad + +newtype IOURef a = IOURef (IOSpecific2 MUVec a) + +INSTANCE_TYPEABLE1(IOURef,ioURefTc,"IOURef") + +-- | Create new unboxed reference in IO monad +newIOURef :: (Unboxed a) => a -> IO (IOURef a) +newIOURef init = do var <- allocUnboxed 1 + writeUnboxed var 0 init + return (IOURef var) + +-- | Read current value of unboxed reference in IO monad +{-# INLINE readIOURef #-} +readIOURef :: (Unboxed a) => IOURef a -> IO a +readIOURef (IOURef ref) = readUnboxed ref 0 + +-- | Change value of unboxed reference in IO monad +{-# INLINE writeIOURef #-} +writeIOURef :: (Unboxed a) => IOURef a -> a -> IO () +writeIOURef (IOURef ref) = writeUnboxed ref 0 + +-- |Modify contents of an 'IOURef' by applying pure function to it +{-# INLINE modifyIOURef #-} +modifyIOURef :: (Unboxed a) => IOURef a -> (a -> a) -> IO () +modifyIOURef ref f = readIOURef ref >>= writeIOURef ref . f + +-- ----------------------------------------------------------------------------- +-- | Unboxed references in ST monad + +newtype STURef s a = STURef (MUVec s a) + +INSTANCE_TYPEABLE2(STURef,stURefTc,"STURef") + +-- | Create new unboxed reference in ST monad +newSTURef :: (Unboxed a) => a -> ST s (STURef s a) +newSTURef init = do var <- allocUnboxed 1 + writeUnboxed var 0 init + return (STURef var) + +-- | Read current value of unboxed reference in ST monad +{-# INLINE readSTURef #-} +readSTURef :: (Unboxed a) => STURef s a -> ST s a +readSTURef (STURef ref) = readUnboxed ref 0 + +-- | Change value of unboxed reference in ST monad +{-# INLINE writeSTURef #-} +writeSTURef :: (Unboxed a) => STURef s a -> a -> ST s () +writeSTURef (STURef ref) = writeUnboxed ref 0 + +-- |Modify contents of an 'STURef' by applying pure function to it +{-# INLINE modifySTURef #-} +modifySTURef :: (Unboxed a) => STURef s a -> (a -> a) -> ST s () +modifySTURef ref f = readSTURef ref >>= writeSTURef ref . f + diff --git a/Data/Ref/Universal.hs b/Data/Ref/Universal.hs new file mode 100644 --- /dev/null +++ b/Data/Ref/Universal.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP, FunctionalDependencies, MultiParamTypeClasses #-} +{- | + Module : Data.Ref.Universal + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +Monad-independent interfaces for boxed and unboxed references + +-} + +module Data.Ref.Universal ( + -- * Monad-independent interface for boxed references + Ref(..), + modifyRef, + modifyRefM, + -- * Monad-independent interface for unboxed references + URef(..), + modifyURef, + modifyURefM, + ) +where + +import Control.Monad.ST (ST) +import Data.IORef +import Data.STRef + +import Data.Unboxed +import Data.Ref.Unboxed + +-- ----------------------------------------------------------------------------- +-- | This class allows to create new boxed reference in monad-independent way +-- (suitable for writing code that will work in IO, ST and other monads) + +class (Monad m) => Ref m r | m->r, r->m where + -- |Create a new 'Ref' with given initial value + newRef :: a -> m (r a) + -- |Read the value of an 'Ref' + readRef :: r a -> m a + -- |Write new value into an 'Ref' + writeRef :: r a -> a -> m () + +instance Ref IO IORef where + newRef = newIORef + readRef = readIORef + writeRef = writeIORef +instance Ref (ST s) (STRef s) where + newRef = newSTRef + readRef = readSTRef + writeRef = writeSTRef + +-- |Modify the contents of an 'Ref' by applying pure function to it +{-# INLINE modifyRef #-} +modifyRef ref f = readRef ref >>= writeRef ref . f + +-- |Modify the contents of an 'Ref' by applying monadic computation to it +{-# INLINE modifyRefM #-} +modifyRefM ref f = readRef ref >>= f >>= writeRef ref + +-- ----------------------------------------------------------------------------- +-- | This class allows to create new unboxed reference in monad-independent way +-- (suitable for writing code that will work in IO, ST and other monads) + +class (Monad m) => URef m r | m->r, r->m where + -- |Create a new 'URef' with given initial value + newURef :: (Unboxed a) => a -> m (r a) + -- |Read the value of an 'URef' + readURef :: (Unboxed a) => r a -> m a + -- |Write new value into an 'URef' + writeURef :: (Unboxed a) => r a -> a -> m () + +instance URef IO IOURef where + newURef = newIOURef + readURef = readIOURef + writeURef = writeIOURef +instance URef (ST s) (STURef s) where + newURef = newSTURef + readURef = readSTURef + writeURef = writeSTURef + +-- |Modify the contents of an 'URef' by applying pure function to it +{-# INLINE modifyURef #-} +modifyURef ref f = readURef ref >>= writeURef ref . f + +-- |Modify the contents of an 'URef' by applying monadic computation to it +{-# INLINE modifyURefM #-} +modifyURefM ref f = readURef ref >>= f >>= writeURef ref + diff --git a/Data/SyntaxSugar.hs b/Data/SyntaxSugar.hs new file mode 100644 --- /dev/null +++ b/Data/SyntaxSugar.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP, FunctionalDependencies, FlexibleInstances, MultiParamTypeClasses #-} +{- | + Module : Data.SyntaxSugar + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +Universal interface for reading and writing mutable data + (references, array and hash elements) +Syntax sugar (=:, +=, val...) based on this interface + +-} + +module Data.SyntaxSugar where + +import Control.Monad.ST (ST) +import Data.ArrayBZ.IO +import Data.ArrayBZ.ST +import Data.ArrayBZ.Storable +import Data.HashTable as Hash +import Data.Ref +import Data.Unboxed +import Foreign.Storable + +-- ----------------------------------------------------------------------------- +-- Universal interface for reading and writing mutable data +-- (references, array and hash elements) + +class (Monad m) => Mutable m r a | r->a where + -- |Read the value of an 'Mutable' + readVar :: r -> m a + -- |Write new value into an 'Mutable' + writeVar :: r -> a -> m () + +-- |Modify the contents of an 'Mutable' by applying pure function to it +{-# INLINE modifyVar #-} +modifyVar var f = readVar var >>= writeVar var . f + +-- |Modify the contents of an 'Mutable' by applying monadic computation to it +{-# INLINE modifyVarM #-} +modifyVarM var f = readVar var >>= f >>= writeVar var + +-- ----------------------------------------------------------------------------- +-- Implementation of `Mutable` interface for references + +instance Mutable IO (IORef a) a where + readVar = readRef + writeVar = writeRef +instance Mutable (ST s) (STRef s a) a where + readVar = readRef + writeVar = writeRef +instance (Unboxed a) => Mutable IO (IOURef a) a where + readVar = readURef + writeVar = writeURef + {-# INLINE readVar #-} + {-# INLINE writeVar #-} +instance (Unboxed a) => Mutable (ST s) (STURef s a) a where + readVar = readURef + writeVar = writeURef + +-- ----------------------------------------------------------------------------- +-- Implementation of `Mutable` interface for elements of MArray, +-- including simplified interfaces for 2-dimensional and 3-dimensional arrays + +instance (Ix i) => Mutable IO (IOArray i e, i) e where + readVar (arr,i) = readArray arr i + writeVar (arr,i) = writeArray arr i + +instance (Unboxed e, Ix i) => Mutable IO (IOUArray i e, i) e where + readVar (arr,i) = readArray arr i + writeVar (arr,i) = writeArray arr i + +instance (Storable e, Ix i) => Mutable IO (StorableArray i e, i) e where + readVar (arr,i) = readArray arr i + writeVar (arr,i) = writeArray arr i + +instance (Ix i) => Mutable (ST s) (STArray s i e, i) e where + readVar (arr,i) = readArray arr i + writeVar (arr,i) = writeArray arr i + +instance (Unboxed e, Ix i) => Mutable (ST s) (STUArray s i e, i) e where + readVar (arr,i) = readArray arr i + writeVar (arr,i) = writeArray arr i + +instance (MArray a e m, Ix i, Ix j) => Mutable m (a (i,j) e, i, j) e where + readVar (arr,i,j) = readArray arr (i,j) + writeVar (arr,i,j) = writeArray arr (i,j) + +instance (MArray a e m, Ix i, Ix j, Ix k) => Mutable m (a (i,j,k) e, i, j, k) e where + readVar (arr,i,j,k) = readArray arr (i,j,k) + writeVar (arr,i,j,k) = writeArray arr (i,j,k) + +-- ----------------------------------------------------------------------------- +-- Implementation of `Mutable` interface for values in HashTable + +instance Mutable IO (HashTable key e, key) e where + readVar (table,key) = do (Just x) <- Hash.lookup table key + return x + writeVar (table,key) e = hashUpdate table key e >> return () + +#if defined(__HUGS_VERSION__) || defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 604) +-- Define this only for Hugs2005+ and GHC 6.4+ +hashUpdate table = Hash.update table +#else +-- Slower implementation for old compilers +hashUpdate table key e = do Hash.delete table key + Hash.insert table key e +#endif + + +-- ----------------------------------------------------------------------------- +-- Syntax sugar for using mutables + +infixl 0 =:, +=, -=, .=, .<- +ref x = newRef x -- create new boxed reference +uref x = newURef x -- create new unboxed reference +val var = readVar var -- read current value of mutable +var=:x = writeVar var x -- assign new value to mutable +var+=x = modifyVar var (\old -> old+x) -- increase value of mutable +var-=x = modifyVar var (\old -> old-x) -- decrease value of mutable +var.=f = modifyVar var (\old -> f old) -- apply pure function to the value of mutable +var.<-f = modifyVarM var (\old -> f old) -- apply monadic computation to the value of mutable + +{-# INLINE ref #-} +{-# INLINE uref #-} +{-# INLINE (=:) #-} +{-# INLINE (+=) #-} +{-# INLINE (-=) #-} diff --git a/Data/Unboxed.hs b/Data/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Data/Unboxed.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{- | + Module : Data.Unboxed + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: Hugs/GHC + +Class 'Unboxed' represents values that can be stored in unboxed vectors + and unboxed references + +Based on the: Hugs.ByteArray module +-} + +module Data.Unboxed ( + UVec, + MUVec, + allocUnboxed, + unsafeFreezeUnboxed, + unsafeThawUnboxed, + freezeUnboxed, + thawUnboxed, + castUnboxed, + castMUnboxed, + + Unboxed, + readUnboxed, + writeUnboxed, + indexUnboxed, + sizeOfUnboxed, + ) +where + +-- On GHC we use fast compiler-specific implementation. +-- On other compilers, slow but universal Storable-based implementation is used +#ifdef __GLASGOW_HASKELL__ + +import GHC.Unboxed + +#else + +import Control.Monad.STorIO +import Data.Int +import Data.Word +import Foreign.ForeignPtr +import Foreign.Marshal.Utils ( copyBytes ) +import Foreign.Ptr +import Foreign.StablePtr +import Foreign.Storable +import System.IO.Unsafe + +-- --------------------------------------------------------------------------- +-- | Immutable and mutable byte vectors + +newtype UVec a = UVec (ForeignPtr a) +newtype MUVec s a = MUVec (ForeignPtr a) + +-- | Alloc the mutable byte vector +allocUnboxedBytes :: (STorIO m s, Integral bytes, Unboxed a) + => bytes -> m (MUVec s a) +allocUnboxedBytes bytes = do + fp <- mLift (mallocForeignPtrBytes (fromIntegral bytes)) + return (MUVec fp) + +-- | Mutable->immutable byte vector on-place conversion +{-# INLINE unsafeFreezeMUVec #-} +unsafeFreezeUnboxed :: (STorIO m s) + => MUVec s a -> m (UVec a) +unsafeFreezeUnboxed (MUVec arr) = do + return (UVec arr) + +-- | Immutable->mutable byte vector on-place conversion +{-# INLINE unsafeThawUVec #-} +unsafeThawUnboxed :: (STorIO m s) + => UVec a -> m (MUVec s a) +unsafeThawUnboxed (UVec arr) = do + return (MUVec arr) + +-- | Mutable->immutable byte vector conversion which takes a copy of contents +freezeUnboxed :: (STorIO m s) + => MUVec s a -> Int -> m (UVec a) +freezeUnboxed (MUVec arr) size = mLift $ do + arr' <- mallocForeignPtrBytes size + withForeignPtr arr $ \p -> + withForeignPtr arr' $ \p' -> + copyBytes p' p size + return (UVec arr') + +-- | Immutable->mutable byte vector conversion which takes a copy of contents +thawUnboxed :: (STorIO m s) => UVec a -> Int -> m (MUVec s a) +thawUnboxed (UVec arr) size = mLift $ do + arr' <- mallocForeignPtrBytes size + withForeignPtr arr $ \p -> + withForeignPtr arr' $ \p' -> + copyBytes p' p size + return (MUVec arr') + +-- --------------------------------------------------------------------------- +-- | Unboxed defined via Storable + +class (Storable value) => Unboxed value +instance (Storable value) => Unboxed value + +-- | Read the value from mutable byte vector at given `index` +{-# INLINE readUnboxed #-} +readUnboxed :: (STorIO m s, Unboxed value, Integral index) + => MUVec s value -> index -> m value +readUnboxed (MUVec arr) index = mLift $ + withForeignPtr arr $ \a -> peekElemOff a (fromIntegral index) + +-- | Write the value to mutable byte vector at given `index` +{-# INLINE writeUnboxed #-} +writeUnboxed :: (STorIO m s, Unboxed value, Integral index) + => MUVec s value -> index -> value -> m () +writeUnboxed (MUVec arr) index value = mLift $ + withForeignPtr arr $ \a -> pokeElemOff a (fromIntegral index) value + +-- | Read the value from immutable byte vector at given `index` +{-# INLINE indexUnboxed #-} +indexUnboxed :: (Unboxed value, Integral index) + => UVec value -> index -> value +indexUnboxed (UVec arr) index = unsafePerformIO $ + withForeignPtr arr $ \a -> peekElemOff a (fromIntegral index) + +-- | How many bytes required to represent values of this type +{-# INLINE sizeOfUnboxed #-} +sizeOfUnboxed :: (Unboxed value, Integral size) + => value -> size +sizeOfUnboxed = fromIntegral . sizeOf + +-- | Recast immutable unboxed vector +castUnboxed :: UVec a -> UVec b +castUnboxed (UVec vec) = UVec (castForeignPtr vec) + +-- | Recast mutable unboxed vector +castMUnboxed :: MUVec s a -> MUVec s b +castMUnboxed (MUVec mvec) = MUVec (castForeignPtr mvec) + +#endif + +-- --------------------------------------------------------------------------- +-- | Additional operations on byte vectors + +-- | Alloc the mutable byte vector having `elems` elements of required type +allocUnboxed :: forall s a elems m. (STorIO m s, Integral elems, Unboxed a) + => elems -> m (MUVec s a) +allocUnboxed elems = + allocUnboxedBytes (fromIntegral elems * sizeOfUnboxed (undefined::a)) + diff --git a/Examples/Array/Boxed.hs b/Examples/Array/Boxed.hs new file mode 100644 --- /dev/null +++ b/Examples/Array/Boxed.hs @@ -0,0 +1,36 @@ +-- This example demonstrates using of Array, IOArray and STArray +import Control.Monad.ST +import Data.ArrayBZ.Boxed + +main = do + -- This section demonstrates using of Array + test_Array |> print + + -- This section demonstrates using of IOArray + test_IOArray >>= print + + -- This section demonstrates using of STArray + runST test_STArray |> print + + +-- Using Array +test_Array = + let array = listArray (1,10) [1..10] :: Array Int Double + elements = elems array + in (sum elements) + +-- Using IOArray +test_IOArray = do + array <- newListArray (1,10) [1..10] :: IO (IOArray Int Double) + elements <- getElems array + return (sum elements) + +-- Using STArray +test_STArray = do + array <- newListArray (1,10) [1..10] :: ST s (STArray s Int Double) + elements <- getElems array + return (sum elements) + +-- Helper operation +a |> b = b a + diff --git a/Examples/Array/Diff.hs b/Examples/Array/Diff.hs new file mode 100644 --- /dev/null +++ b/Examples/Array/Diff.hs @@ -0,0 +1,25 @@ +-- This example demonstrates using of DiffArray and DiffUArray +import Data.ArrayBZ.Diff + +main = do + -- This section demonstrates using of DiffArray + test_DiffArray |> print + + -- This section demonstrates using of DiffUArray + test_DiffUArray |> print + +-- Using DiffArray +test_DiffArray = + let array = listArray (1,10) [1..10] :: DiffArray Int Double + elements = elems array + in (sum elements) + +-- Using DiffUArray +test_DiffUArray = + let array = listArray (1,10) [1..10] :: DiffUArray Int Double + elements = elems array + in (sum elements) + +-- Helper operation +a |> b = b a + diff --git a/Examples/Array/Dynamic.hs b/Examples/Array/Dynamic.hs new file mode 100644 --- /dev/null +++ b/Examples/Array/Dynamic.hs @@ -0,0 +1,45 @@ +-- This example demonstrates using of `DynamicIOArray`, +-- i.e. arrays whose bounds can be changed dynamically, +-- including automatic growth as `writeArray` requires. +-- +-- Other types of dynamic arrays - DynamicIOUArray, DynamicSTArray, +-- DynamicSTUArray and manually constructed dynamic array types +-- can be used in the same fashion. +import Data.ArrayBZ.Dynamic + +main = do + -- This array will grow at least two times each time when index is out of bounds, + -- because it is created using `newDynamicArray growTwoTimes` + arr <- newDynamicArray growTwoTimes (0,-1) 99 :: IO (DynamicIOArray Int Int) + -- At this moment the array is empty + printArray arr + + -- During this cycle the array extended 3 times + for [0..5] $ \i -> + writeArray arr i i + printArray arr + + -- During this cycle the array extended one more time + for [-5 .. -1] $ \i -> + writeArray arr i i + printArray arr + + -- Operation that explicitly resizes the array + resizeDynamicArray arr (3,15) + printArray arr + + -- This array will not grow automatically because it is created using `newArray`, + -- but it can be resized explicitly using `resizeDynamicArray` + arr <- newArray (0,-1) 99 :: IO (DynamicIOArray Int Int) + resizeDynamicArray arr (0,0) + printArray arr + writeArray arr 1 1 -- this operation raises error + + +-- Print dynamic array bounds and contents +printArray arr = do + bounds <- getBounds arr + contents <- getElems arr + putStrLn (show bounds++" : "++show contents) + +for list action = mapM_ action list diff --git a/Examples/Array/IO.hs b/Examples/Array/IO.hs new file mode 100644 --- /dev/null +++ b/Examples/Array/IO.hs @@ -0,0 +1,26 @@ +-- This example demonstrates using of IOArray and IOUArray +import Data.ArrayBZ.IO + +main = do + -- This section demonstrates using of IOArray + test_IOArray >>= print + + -- This section demonstrates using of IOUArray + test_IOUArray >>= print + + +-- Using IOArray +test_IOArray = do + array <- newListArray (1,10) [1..10] :: IO (IOArray Int Double) + elements <- getElems array + return (sum elements) + +-- Using IOUArray +test_IOUArray = do + array <- newListArray (1,10) [1..10] :: IO (IOUArray Int Double) + elements <- getElems array + return (sum elements) + +-- Helper operation +a |> b = b a + diff --git a/Examples/Array/ST.hs b/Examples/Array/ST.hs new file mode 100644 --- /dev/null +++ b/Examples/Array/ST.hs @@ -0,0 +1,27 @@ +-- This example demonstrates using of STArray and STUArray +import Control.Monad.ST +import Data.ArrayBZ.ST + +main = do + -- This section demonstrates using of STArray + runST test_STArray |> print + + -- This section demonstrates using of STUArray + runST test_STUArray |> print + + +-- Using STArray +test_STArray = do + array <- newListArray (1,10) [1..10] :: ST s (STArray s Int Double) + elements <- getElems array + return (sum elements) + +-- Using STUArray +test_STUArray = do + array <- newListArray (1,10) [1..10] :: ST s (STUArray s Int Double) + elements <- getElems array + return (sum elements) + +-- Helper operation +a |> b = b a + diff --git a/Examples/Array/Storable.hs b/Examples/Array/Storable.hs new file mode 100644 --- /dev/null +++ b/Examples/Array/Storable.hs @@ -0,0 +1,14 @@ +-- This example demonstrates using of StorableArray +import Data.ArrayBZ.Storable + +main = do + -- This section demonstrates using of StorableArray + test_StorableArray >>= print + + +-- Using StorableArray +test_StorableArray = do + array <- newListArray (1,10) [1..10] :: IO (StorableArray Int Double) + elements <- getElems array + return (sum elements) + diff --git a/Examples/Array/Unboxed.hs b/Examples/Array/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Examples/Array/Unboxed.hs @@ -0,0 +1,36 @@ +-- This example demonstrates using of UArray, IOUArray and STUArray +import Control.Monad.ST +import Data.ArrayBZ.Unboxed + +main = do + -- This section demonstrates using of UArray + test_UArray |> print + + -- This section demonstrates using of IOUArray + test_IOUArray >>= print + + -- This section demonstrates using of STUArray + runST test_STUArray |> print + + +-- Using UArray +test_UArray = + let array = listArray (1,10) [1..10] :: UArray Int Double + elements = elems array + in (sum elements) + +-- Using IOUArray +test_IOUArray = do + array <- newListArray (1,10) [1..10] :: IO (IOUArray Int Double) + elements <- getElems array + return (sum elements) + +-- Using STUArray +test_STUArray = do + array <- newListArray (1,10) [1..10] :: ST s (STUArray s Int Double) + elements <- getElems array + return (sum elements) + +-- Helper operation +a |> b = b a + diff --git a/Examples/SyntaxSugar.hs b/Examples/SyntaxSugar.hs new file mode 100644 --- /dev/null +++ b/Examples/SyntaxSugar.hs @@ -0,0 +1,81 @@ +-- This module demonstrates using of syntax sugar when manipulating +-- references, arrays and hash tables, including implementation +-- of monad-independent algorithms with references +import Control.Monad.ST +import Data.SyntaxSugar +import Data.Ref +import Data.ArrayBZ.IO +import Data.HashTable as Hash + +main = do + -- This section demonstrates running of monad-independent + -- algorithm that use boxed references in IO and ST monads + test_Ref 5 >>= print + runST (test_Ref 6) |> print + + -- This section demonstrates running of monad-independent + -- algorithm that use unboxed references in IO and ST monads + test_URef 7 >>= print + runST (test_URef 8) |> print + + -- Using syntax sugar with arrays + test_Array >>= print + + -- Using syntax sugar with hash tables + test_Hash >>= print + + +-- Monad-independent computation that uses boxed reference +test_Ref init = do + x <- ref (0::Int) + x =: init + x += 10 + x -= 2 + x .= (*2) + val x + +-- Monad-independent computation that uses unboxed reference +test_URef init = do + x <- uref (0::Int) + x =: init + x += 10 + x -= 2 + x .= (*2) + val x + +-- Using syntax sugar with arrays +test_Array = do + let i = 0::Int + + arr <- newArray (0,9) 0 :: IO (IOArray Int Double) + (arr,i) =: 1 + (arr,i) += 10 + (arr,i) -= 2 + (arr,i) .= (*2) + x <- val (arr,i) + + arr2 <- newArray ((0,0), (9,9)) 0 :: IO (IOArray (Int,Int) Double) + (arr2,i,i) =: 1 + (arr2,i,i) += 10 + (arr2,i,i) -= 2 + (arr2,i,i) .= (*2) + y <- val (arr2,i,i) + + return (x,y) + + +-- Using syntax sugar with hash tables +test_Hash = do + let key = "test" + hash <- Hash.new (==) hashString + (hash,key) =: 1 + (hash,key) += 10 + (hash,key) -= 2 + (hash,key) .= (*2) + val (hash,key) + + +-- Helper operations +a |> b = b a +for list action = mapM_ action list + diff --git a/Examples/URef.hs b/Examples/URef.hs new file mode 100644 --- /dev/null +++ b/Examples/URef.hs @@ -0,0 +1,29 @@ +-- This program demonstrates using of fast unboxed references in IO and ST monads +import Control.Monad.ST +import Data.Ref +import Data.Ref.LazyST () + +main = do + -- IOURef is fast unboxed reference in IO monad + test_IOURef 1 >>= print + + -- STURef is fast unboxed reference in ST monad + runST (test_STURef 2) |> print + + +-- Using 'IOURef Int' +test_IOURef init = do + x <- newIOURef (init::Int) + x0 <- readIOURef x + writeIOURef x (x0+10) + readIOURef x + +-- Using 'STURef Int' +test_STURef init = do + x <- newSTURef (init::Int) + x0 <- readSTURef x + writeSTURef x (x0+10) + readSTURef x + +-- Helper operation +a |> b = b a diff --git a/Examples/Universal.hs b/Examples/Universal.hs new file mode 100644 --- /dev/null +++ b/Examples/Universal.hs @@ -0,0 +1,37 @@ +-- This program demonstrates implementation of monad-independent algorithms +-- using Ref and URef classes +import Control.Monad.ST +import Data.Ref + +main = do + -- This section demonstrates running of monad-independent algrorithm + -- `test_Ref` in IO and ST monads + test_Ref 3 >>= print + runST (test_Ref 4) |> print + + -- This section demonstrates running of monad-independent algrorithm + -- `test_URef` in IO and ST monads + test_URef 5 >>= print + runST (test_URef 6) |> print + + +-- Using class 'Ref' +test_Ref init = do + x <- newRef (init::Int) -- `newRef` operation will create + -- * IORef in IO monad + -- * STRef in ST monad + x0 <- readRef x -- `readRef` and `writeRef` operations + writeRef x (x0+10) -- works with references of both types + readRef x + +-- Using class 'URef' +test_URef init = do + x <- newURef (init::Int) -- `newURef` operation will create + -- * IOURef in IO monad + -- * STURef in ST monad + x0 <- readURef x -- `readURef` and `writeURef` operations + writeURef x (x0+10) -- works with references of both types + readURef x + +-- Helper operation +a |> b = b a diff --git a/GHC/ArrBZ.hs b/GHC/ArrBZ.hs new file mode 100644 --- /dev/null +++ b/GHC/ArrBZ.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE UnboxedTuples, MagicHash #-} +{- | + Module : GHC.ArrBZ + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC + +Vectors of boxed values + +-} + +module GHC.ArrBZ where + +import GHC.Base + +import Control.Monad.STorIO + +-- --------------------------------------------------------------------------- +-- | Immutable and mutable vectors of boxed values + +data Vec a = Vec (Array# a) +data MVec s a = MVec (MutableArray# s a) + +-- | Alloc the mutable vector +allocBoxed :: (STorIO m s, Integral elems) => elems -> a -> m (MVec s a) +-- | Mutable->immutable vector on-place conversion +unsafeFreezeBoxed :: (STorIO m s) => MVec s a -> m (Vec a) +-- | Immutable->mutable vector on-place conversion +unsafeThawBoxed :: (STorIO m s) => Vec a -> m (MVec s a) +-- | Mutable->immutable vector conversion which takes a copy of contents +freezeBoxed :: (STorIO m s) => MVec s a -> Int -> a -> m (Vec a) +-- | Immutable->mutable vector conversion which takes a copy of contents +thawBoxed :: (STorIO m s) => Vec a -> Int -> a -> m (MVec s a) + + +allocBoxed elems init = mLift ( \s -> + case newArray# (fromI# elems) init s of { (# s, arr #) -> + (# s, MVec arr #) } ) + +{-# INLINE unsafeFreezeBoxed #-} +unsafeFreezeBoxed (MVec mvec) = mLift ( \s -> + case unsafeFreezeArray# mvec s of { (# s, vec #) -> + (# s, Vec vec #) } ) + +{-# INLINE unsafeThawBoxed #-} +unsafeThawBoxed (Vec arr#) = mLift ( \s -> + case unsafeThawArray# arr# s of { (# s, marr# #) -> + (# s, MVec marr# #) } ) + +freezeBoxed (MVec marr#) (I# n#) init = mLift ( \s1# -> + case newArray# n# init s1# of { (# s2#, tmparr# #) -> + + let copy i# s01# | i# ==# n# = s01# + | otherwise = + case readArray# marr# i# s01# of { (# s02#, e #) -> + case writeArray# tmparr# i# e s02# of { s03# -> + copy (i# +# 1#) s03# }} in + + case copy 0# s2# of { s3# -> + case unsafeFreezeArray# tmparr# s3# of { (# s4#, arr# #) -> + (# s4#, Vec arr# #) }}} ) + +thawBoxed (Vec vec#) (I# n#) init = mLift ( \s1# -> + case newArray# n# init s1# of { (# s2#, mvec# #) -> + + let copy i# s01# | i# ==# n# = s01# + | otherwise = + case indexArray# vec# i# of { (# e #) -> + case writeArray# mvec# i# e s01# of { s02# -> + copy (i# +# 1#) s02# }} in + + case copy 0# s2# of { s3# -> + (# s3#, MVec mvec# #) }} ) + +-- Implementation helper function that converts any integral value to the Int# +{-# INLINE fromI# #-} +fromI# :: (Integral n) => n -> Int# +fromI# n = n# where I# n# = fromIntegral n + +-- --------------------------------------------------------------------------- +-- Read/write/index vector elements + +-- | Read the value from mutable vector at given `index` +readBoxed :: (STorIO m s, Integral index) => MVec s value -> index -> m value +-- | Write the value to mutable vector at given `index` +writeBoxed :: (STorIO m s, Integral index) => MVec s value -> index -> value -> m () +-- | Read the value from immutable vector at given `index` +indexBoxed :: (Integral index) => Vec value -> index -> value + + +{-# INLINE readBoxed #-} +readBoxed (MVec vec) index = mLift (readArray# vec (fromI# index)) + +{-# INLINE writeBoxed #-} +writeBoxed (MVec vec) index value = mLift ( \s -> + case writeArray# vec (fromI# index) value s of { s -> + (# s, () #) } ) + +{-# INLINE indexBoxed #-} +indexBoxed (Vec vec) index = + case indexArray# vec (fromI# index) of { (# s #) -> s } + diff --git a/GHC/Unboxed.hs b/GHC/Unboxed.hs new file mode 100644 --- /dev/null +++ b/GHC/Unboxed.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE FunctionalDependencies, FlexibleInstances, UnliftedFFITypes, + CPP, KindSignatures, MagicHash, UnboxedTuples, ForeignFunctionInterface, + MultiParamTypeClasses #-} +{- | + Module : GHC.Unboxed + Copyright : Copyright (C) 2006 Bulat Ziganshin + License : BSD3 + + Maintainer : Bulat Ziganshin + Stability : experimental + Portability: GHC + +Unboxed values (simple datatypes that can be stored in ByteArrays, + i.e. raw memory buffers allocated inside the Haskell heap) + +Based on the idea of Oleg Kiselyov + (see http://www.haskell.org/pipermail/haskell-cafe/2004-July/006400.html) +-} + +module GHC.Unboxed where + +import GHC.ST ( ST(..), runST ) +import GHC.IOBase ( IO(..) ) +import GHC.Base +import GHC.Word ( Word(..) ) +import GHC.Ptr ( Ptr(..), FunPtr(..) ) +import GHC.Float ( Float(..), Double(..) ) +import GHC.Stable ( StablePtr(..) ) +import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) +import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) ) +import Control.Monad.ST.Lazy ( strictToLazyST ) +import qualified Control.Monad.ST.Lazy as Lazy (ST) +import Foreign.Storable + +-- --------------------------------------------------------------------------- +-- | That's all we need to unify ST and IO operations! +class (Monad m) => STorIO m s | m->s where + mLift :: (State# s -> (# State# s, a #)) -> m a + +instance STorIO (ST s) s where + {-# INLINE mLift #-} + mLift = ST + +instance STorIO (Lazy.ST s) s where + {-# INLINE mLift #-} + mLift = strictToLazyST . ST + +instance STorIO IO RealWorld where + {-# INLINE mLift #-} + mLift = IO + +-- | Type functions which converts universal ST or IO types to IO-specific ones +type IOSpecific (a :: * -> *) = a RealWorld +type IOSpecific2 (a :: * -> * -> *) = a RealWorld +type IOSpecific3 (a :: * -> * -> * -> *) = a RealWorld + +-- --------------------------------------------------------------------------- +-- | Immutable and mutable byte vectors + +data UVec a = UVec ByteArray# +data MUVec s a = MUVec (MutableByteArray# s) + +-- | Alloc the mutable byte vector +allocUnboxedBytes :: (STorIO m s, Integral bytes, Unboxed a) + => bytes -> m (MUVec s a) +allocUnboxedBytes bytes = mLift ( \s -> + case newByteArray# (fromI# bytes) s of { (# s, arr #) -> + (# s, MUVec arr #) } ) + +-- | Mutable->immutable byte vector on-place conversion +{-# INLINE unsafeFreezeUnboxed #-} +unsafeFreezeUnboxed :: (STorIO m s) => MUVec s a -> m (UVec a) +unsafeFreezeUnboxed (MUVec marr#) = mLift ( \s -> + case unsafeFreezeByteArray# marr# s of { (# s, arr# #) -> + (# s, UVec arr# #) } ) + +-- | Immutable->mutable byte vector on-place conversion +{-# INLINE unsafeThawUnboxed #-} +unsafeThawUnboxed :: (STorIO m s) => UVec a -> m (MUVec s a) +unsafeThawUnboxed (UVec arr#) = mLift ( \s -> + (# s, MUVec (unsafeCoerce# arr#) #) ) + +-- | Mutable->immutable byte vector conversion which takes a copy of contents +freezeUnboxed :: (STorIO m s) => MUVec s a -> Int -> m (UVec a) +freezeUnboxed (MUVec marr#) (I# size) = mLift ( \s1# -> + case newByteArray# size s1# of { (# s2#, tmparr# #) -> + case unsafeCoerce# memcpy tmparr# marr# size s2# of { (# s3#, () #) -> + case unsafeFreezeByteArray# tmparr# s3# of { (# s4#, arr# #) -> + (# s3#, UVec arr# #) }}} ) + +-- | Immutable->mutable byte vector conversion which takes a copy of contents +thawUnboxed :: (STorIO m s) => UVec a -> Int -> m (MUVec s a) +thawUnboxed (UVec arr#) (I# size) = mLift ( \s1# -> + case newByteArray# size s1# of { (# s2#, marr# #) -> + case unsafeCoerce# memcpy marr# arr# size s2# of { (# s3#, () #) -> + (# s3#, MUVec marr# #) }} ) + +-- | Recast immutable unboxed vector +castUnboxed :: UVec a -> UVec b +castUnboxed (UVec vec) = UVec vec + +-- | Recast mutable unboxed vector +castMUnboxed :: MUVec s a -> MUVec s b +castMUnboxed (MUVec mvec) = MUVec mvec + +-- Implementation helper function that converts any integral value to the Int# +{-# INLINE fromI# #-} +fromI# :: (Integral n) => n -> Int# +fromI# n = n# where I# n# = fromIntegral n + +-- Implementation helper function that copies data between byte vectors +foreign import ccall unsafe "memcpy" + memcpy :: MutableByteArray# RealWorld -> ByteArray# -> Int# -> IO () + +-- --------------------------------------------------------------------------- +-- | Unboxed is like Storable, but values are stored in byte vectors (i.e. inside the Haskell heap) + +class Unboxed value where + -- | Read the value from mutable byte vector at given `index` + readUnboxed :: (STorIO m s, Integral index) => MUVec s value -> index -> m value + -- | Write the value to mutable byte vector at given `index` + writeUnboxed :: (STorIO m s, Integral index) => MUVec s value -> index -> value -> m () + -- | Read the value from immutable byte vector at given `index` + indexUnboxed :: (Integral index) => UVec value -> index -> value + -- | How many bytes required to represent values of this type + sizeOfUnboxed :: value -> Int + +-- Universal defition for Enum types having <= 256 variants +instance Unboxed Bool where +{ + {-# INLINE readUnboxed #-}; + readUnboxed (MUVec arr) index = mLift ( \s -> + case readInt8Array# arr (fromI# index) s of { (# s, value# #) -> + (# s, tagToEnum# value# #) } ); + + {-# INLINE writeUnboxed #-}; + writeUnboxed (MUVec arr) index value = mLift ( \s -> + case writeInt8Array# arr (fromI# index) (getTag value) s of { s -> + (# s, () #) } ); + + {-# INLINE indexUnboxed #-}; + indexUnboxed (UVec arr) index = tagToEnum# (indexInt8Array# arr (fromI# index)); + + {-# INLINE sizeOfUnboxed #-}; + sizeOfUnboxed _ = 1; +} + +-- Universal defition for Storable types +#define InstanceUnboxed(type, cast, read, write, at) \ +instance Unboxed type where \ +{ \ + {-# INLINE readUnboxed #-}; \ + readUnboxed (MUVec arr) index = mLift ( \s -> \ + case read arr (fromI# index) s of { (# s, value# #) -> \ + (# s, cast value# #) } ); \ + \ + {-# INLINE writeUnboxed #-}; \ + writeUnboxed (MUVec arr) index (cast value#) = mLift ( \s -> \ + case write arr (fromI# index) value# s of { s -> \ + (# s, () #) } ); \ + \ + {-# INLINE indexUnboxed #-}; \ + indexUnboxed (UVec arr) index = cast (at arr (fromI# index)); \ + \ + {-# INLINE sizeOfUnboxed #-}; \ + sizeOfUnboxed = sizeOf; \ +} \ + +InstanceUnboxed( Char, C#, readWideCharArray#, writeWideCharArray#, indexWideCharArray#) +InstanceUnboxed( Int, I#, readIntArray#, writeIntArray#, indexIntArray#) +InstanceUnboxed( Int8, I8#, readInt8Array#, writeInt8Array#, indexInt8Array#) +InstanceUnboxed( Int16, I16#, readInt16Array#, writeInt16Array#, indexInt16Array#) +InstanceUnboxed( Int32, I32#, readInt32Array#, writeInt32Array#, indexInt32Array#) +InstanceUnboxed( Int64, I64#, readInt64Array#, writeInt64Array#, indexInt64Array#) +InstanceUnboxed( Word, W#, readWordArray#, writeWordArray#, indexWordArray#) +InstanceUnboxed( Word8, W8#, readWord8Array#, writeWord8Array#, indexWord8Array#) +InstanceUnboxed( Word16, W16#, readWord16Array#, writeWord16Array#, indexWord16Array#) +InstanceUnboxed( Word32, W32#, readWord32Array#, writeWord32Array#, indexWord32Array#) +InstanceUnboxed( Word64, W64#, readWord64Array#, writeWord64Array#, indexWord64Array#) +InstanceUnboxed( Float, F#, readFloatArray#, writeFloatArray#, indexFloatArray#) +InstanceUnboxed( Double, D#, readDoubleArray#, writeDoubleArray#, indexDoubleArray#) +InstanceUnboxed( (Ptr a), Ptr, readAddrArray#, writeAddrArray#, indexAddrArray#) +InstanceUnboxed( (FunPtr a), FunPtr, readAddrArray#, writeAddrArray#, indexAddrArray#) +InstanceUnboxed( (StablePtr a), StablePtr, readStablePtrArray#, writeStablePtrArray#, indexStablePtrArray#) + diff --git a/Hugs/Typeable.h b/Hugs/Typeable.h new file mode 100644 --- /dev/null +++ b/Hugs/Typeable.h @@ -0,0 +1,70 @@ +/* ---------------------------------------------------------------------------- + * Macros to help make Typeable instances. + * + * INSTANCE_TYPEABLEn(tc,tcname,"tc") defines + * + * instance Typeable/n/ tc + * instance Typeable a => Typeable/n-1/ (tc a) + * instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b) + * ... + * instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an) + * -------------------------------------------------------------------------- */ + +#ifndef TYPEABLE_H +#define TYPEABLE_H + +#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } + +#ifdef __GLASGOW_HASKELL__ + +/* For GHC, the extra instances follow from general instance declarations + * defined in Data.Typeable. */ + +#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } + +#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } + +#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } + +#elif defined(__HUGS__) && defined(__HUGS_VERSION__) && (__HUGS_VERSION__>=2005) + +#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \ +instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault } + +#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \ +instance Typeable a => Typeable1 (tycon a) where { \ + typeOf1 = typeOf1Default }; \ +instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ + typeOf = typeOfDefault } + +#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \ +instance Typeable a => Typeable2 (tycon a) where { \ + typeOf2 = typeOf2Default }; \ +instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \ + typeOf1 = typeOf1Default }; \ +instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \ + typeOf = typeOfDefault } + +#else + +#define INSTANCE_TYPEABLE1(tycon,tcname,str) +#define INSTANCE_TYPEABLE2(tycon,tcname,str) +#define INSTANCE_TYPEABLE3(tycon,tcname,str) + +#endif /* !__GLASGOW_HASKELL__ */ + +#endif diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) The University of Glasgow 2001 + (c) Bulat Ziganshin 2006 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the authro nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO