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 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
-- -XUndecidableInstances, 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 Bool) 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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) Bool where
 bounds a = unsafePerformIO $ boundsDiffArray a
 numElements a = unsafePerformIO $ numElementsDiffArray 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) Char where
 bounds a = unsafePerformIO $ boundsDiffArray a
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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
 numElements a = unsafePerformIO $ numElementsDiffArray 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)
arr `replaceDiffArray2` ies = do
 mapM_ (\(a,b) -> evaluate a >> evaluate b) ies
 arr `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'

numElementsDiffArray :: (MArray a e IO, Ix ix)
 => IOToDiffArray a ix e
 -> IO Int
numElementsDiffArray a
 = do d <- readMVar (varDiffArray a)
 case d of
 Current a' -> getNumElements a'
 Diff a' _ -> numElementsDiffArray 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
 #-}