Diff.hs

{-# 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 <Bulat.Ziganshin@gmail.com>
   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 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.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_ (\(b,c) -> do evaluate b; evaluate c) 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
    #-}