libhugs-base-bundled 98.200609.21-5.3 / usr / lib / hugs / packages / base / Data / Array / Diff.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Array.Diff
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (uses Data.Array.IArray)
--
-- Functional arrays with constant-time update.
--
-----------------------------------------------------------------------------

module Data.Array.Diff (

    -- * Diff array types

    -- | Diff arrays have an immutable interface, but rely on internal
    -- updates in place to provide fast functional update operator
    -- '//'.
    --
    -- When the '//' operator is applied to a diff array, its contents
    -- are physically updated in place. The old array silently changes
    -- its representation without changing the visible behavior:
    -- it stores a link to the new current array along with the
    -- difference to be applied to get the old contents.
    --
    -- So if a diff array is used in a single-threaded style,
    -- i.e. after '//' application the old version is no longer used,
    -- @a'!'i@ takes O(1) time and @a '//' d@ takes O(@length d@).
    -- Accessing elements of older versions gradually becomes slower.
    --
    -- Updating an array which is not current makes a physical copy.
    -- The resulting array is unlinked from the old family. So you
    -- can obtain a version which is guaranteed to be current and
    -- thus have fast element access by @a '//' []@.

    -- Possible improvement for the future (not implemented now):
    -- make it possible to say "I will make an update now, but when
    -- I later return to the old version, I want it to mutate back
    -- instead of being copied".

    IOToDiffArray, -- data IOToDiffArray
                   --     (a :: * -> * -> *) -- internal mutable array
                   --     (i :: *)           -- indices
                   --     (e :: *)           -- elements

    -- | Type synonyms for the two most important IO array types.

    -- Two most important diff array types are fully polymorphic
    -- lazy boxed DiffArray:
    DiffArray,     -- = IOToDiffArray IOArray
    -- ...and strict unboxed DiffUArray, working only for elements
    -- of primitive types but more compact and usually faster:
    DiffUArray,    -- = IOToDiffArray IOUArray

    -- * Overloaded immutable array interface
    
    -- | Module "Data.Array.IArray" provides the interface of diff arrays.
    -- They are instances of class 'IArray'.
    module Data.Array.IArray,

    -- * Low-level interface

    -- | These are really internal functions, but you will need them
    -- to make further 'IArray' instances of various diff array types
    -- (for either more 'MArray' types or more unboxed element types).
    newDiffArray, readDiffArray, replaceDiffArray
    )
    where

------------------------------------------------------------------------
-- Imports.

import Prelude

import Data.Ix
import Data.Array.Base
import Data.Array.IArray
import Data.Array.IO

import Foreign.Ptr        ( Ptr, FunPtr )
import Foreign.StablePtr  ( StablePtr )
import Data.Int           ( Int8,  Int16,  Int32,  Int64 )
import Data.Word          ( Word, Word8, Word16, Word32, Word64 )

import System.IO.Unsafe	  ( unsafePerformIO )
import Control.Exception  ( evaluate )
import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, readMVar )

------------------------------------------------------------------------
-- Diff array types.

-- | An arbitrary 'MArray' type living in the 'IO' monad can be converted
-- to a diff array.

newtype IOToDiffArray a i e =
    DiffArray {varDiffArray :: MVar (DiffArrayData a i e)}

-- Internal representation: either a mutable array, or a link to
-- another diff array patched with a list of index+element pairs.
data DiffArrayData a i e = Current (a i e)
                         | Diff (IOToDiffArray a i e) [(Int, e)]

-- | Fully polymorphic lazy boxed diff array.
type DiffArray  = IOToDiffArray IOArray

-- | Strict unboxed diff array, working only for elements
-- of primitive types but more compact and usually faster than 'DiffArray'.
type DiffUArray = IOToDiffArray IOUArray

-- Having 'MArray a e IO' in instance context would require
-- -fallow-undecidable-instances, so each instance is separate here.

------------------------------------------------------------------------
-- Showing DiffArrays

instance (Ix ix, Show ix, Show e) => Show (DiffArray ix e) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Char) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Int) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Word) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Float) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Double) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Int8) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Int16) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Int32) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Int64) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Word8) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Word16) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Word32) where
  showsPrec = showsIArray

instance (Ix ix, Show ix) => Show (DiffUArray ix Word64) where
  showsPrec = showsIArray

------------------------------------------------------------------------
-- Boring instances.

instance IArray (IOToDiffArray IOArray) e where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray1` ies

instance IArray (IOToDiffArray IOUArray) Char where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Int where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Word where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) (Ptr a) where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) (FunPtr a) where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Float where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Double where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) (StablePtr a) where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Int8 where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Int16 where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Int32 where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Int64 where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Word8 where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Word16 where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Word32 where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies

instance IArray (IOToDiffArray IOUArray) Word64 where
    bounds        a      = unsafePerformIO $ boundsDiffArray a
    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies



------------------------------------------------------------------------
-- The important stuff.

newDiffArray :: (MArray a e IO, Ix i)
             => (i,i)
             -> [(Int, e)]
             -> IO (IOToDiffArray a i e)
newDiffArray (l,u) ies = do
    a <- newArray_ (l,u)
    sequence_ [unsafeWrite a i e | (i, e) <- ies]
    var <- newMVar (Current a)
    return (DiffArray var)

readDiffArray :: (MArray a e IO, Ix i)
              => IOToDiffArray a i e
              -> Int
              -> IO e
a `readDiffArray` i = do
    d <- readMVar (varDiffArray a)
    case d of
        Current a'  -> unsafeRead a' i
        Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies)

replaceDiffArray :: (MArray a e IO, Ix i)
                => IOToDiffArray a i e
                -> [(Int, e)]
                -> IO (IOToDiffArray a i e)
a `replaceDiffArray` ies = do
    d <- takeMVar (varDiffArray a)
    case d of
        Current a' -> case ies of
            [] -> do
                -- We don't do the copy when there is nothing to change
                -- and this is the current version. But see below.
                putMVar (varDiffArray a) d
                return a
            _:_ -> do
                diff <- sequence [do e <- unsafeRead a' i; return (i, e)
                                  | (i, _) <- ies]
                sequence_ [unsafeWrite a' i e | (i, e) <- ies]
                var' <- newMVar (Current a')
                putMVar (varDiffArray a) (Diff (DiffArray var') diff)
                return (DiffArray var')
        Diff _ _ -> do
            -- We still do the copy when there is nothing to change
            -- but this is not the current version. So you can use
            -- 'a // []' to make sure that the resulting array has
            -- fast element access.
            putMVar (varDiffArray a) d
            a' <- thawDiffArray a
                -- thawDiffArray gives a fresh array which we can
                -- safely mutate.
            sequence_ [unsafeWrite a' i e | (i, e) <- ies]
            var' <- newMVar (Current a')
            return (DiffArray var')

-- The elements of the diff list might recursively reference the
-- array, so we must seq them before taking the MVar to avoid
-- deadlock.
replaceDiffArray1 :: (MArray a e IO, Ix i)
                => IOToDiffArray a i e
                -> [(Int, e)]
                -> IO (IOToDiffArray a i e)
a `replaceDiffArray1` ies = do
    mapM_ (evaluate . fst) ies
    a `replaceDiffArray` ies

-- If the array contains unboxed elements, then the elements of the
-- diff list may also recursively reference the array from inside
-- replaceDiffArray, so we must seq them too.
replaceDiffArray2 :: (MArray a e IO, Ix i)
                => IOToDiffArray a i e
                -> [(Int, e)]
                -> IO (IOToDiffArray a i e)
a `replaceDiffArray2` ies = do
    mapM_ (\(a,b) -> do evaluate a; evaluate b) ies
    a `replaceDiffArray` ies


boundsDiffArray :: (MArray a e IO, Ix ix)
                => IOToDiffArray a ix e
                -> IO (ix,ix)
boundsDiffArray a = do
    d <- readMVar (varDiffArray a)
    case d of
        Current a' -> getBounds a'
        Diff a' _  -> boundsDiffArray a'

freezeDiffArray :: (MArray a e IO, Ix ix)
                => a ix e
                -> IO (IOToDiffArray a ix e)
freezeDiffArray a = do
  (l,u) <- getBounds a
  a' <- newArray_ (l,u)
  sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]]
  var <- newMVar (Current a')
  return (DiffArray var)

{-# RULES
"freeze/DiffArray" freeze = freezeDiffArray
    #-}

-- unsafeFreezeDiffArray is really unsafe. Better don't use the old
-- array at all after freezing. The contents of the source array will
-- be changed when '//' is applied to the resulting array.

unsafeFreezeDiffArray :: (MArray a e IO, Ix ix)
                      => a ix e
                      -> IO (IOToDiffArray a ix e)
unsafeFreezeDiffArray a = do
    var <- newMVar (Current a)
    return (DiffArray var)

{-# RULES
"unsafeFreeze/DiffArray" unsafeFreeze = unsafeFreezeDiffArray
    #-}

thawDiffArray :: (MArray a e IO, Ix ix)
              => IOToDiffArray a ix e
              -> IO (a ix e)
thawDiffArray a = do
    d <- readMVar (varDiffArray a)
    case d of
        Current a' -> do
	    (l,u) <- getBounds a'
            a'' <- newArray_ (l,u)
            sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize (l,u) - 1]]
            return a''
        Diff a' ies -> do
            a'' <- thawDiffArray a'
            sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
            return a''

{-# RULES
"thaw/DiffArray" thaw = thawDiffArray
    #-}

-- unsafeThawDiffArray is really unsafe. Better don't use the old
-- array at all after thawing. The contents of the resulting array
-- will be changed when '//' is applied to the source array.

unsafeThawDiffArray :: (MArray a e IO, Ix ix)
                    => IOToDiffArray a ix e
                    -> IO (a ix e)
unsafeThawDiffArray a = do
    d <- readMVar (varDiffArray a)
    case d of
        Current a'  -> return a'
        Diff a' ies -> do
            a'' <- unsafeThawDiffArray a'
            sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
            return a''

{-# RULES
"unsafeThaw/DiffArray" unsafeThaw = unsafeThawDiffArray
    #-}