Data/Array/Diff.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Data.Array.Diff
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable
  10 --
  11 -- Functional arrays with constant-time update.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Data.Array.Diff (
  16
  17     -- * Diff array types
  18
  19     -- | Diff arrays have an immutable interface, but rely on internal
  20     -- updates in place to provide fast functional update operator
  21     -- '//'.
  22     --
  23     -- When the '//' operator is applied to a diff array, its contents
  24     -- are physically updated in place. The old array silently changes
  25     -- its representation without changing the visible behavior:
  26     -- it stores a link to the new current array along with the
  27     -- difference to be applied to get the old contents.
  28     --
  29     -- So if a diff array is used in a single-threaded style,
  30     -- i.e. after '//' application the old version is no longer used,
  31     -- @a'!'i@ takes O(1) time and @a '//' d@ takes O(@length d@).
  32     -- Accessing elements of older versions gradually becomes slower.
  33     --
  34     -- Updating an array which is not current makes a physical copy.
  35     -- The resulting array is unlinked from the old family. So you
  36     -- can obtain a version which is guaranteed to be current and
  37     -- thus have fast element access by @a '//' []@.
  38
  39     -- Possible improvement for the future (not implemented now):
  40     -- make it possible to say "I will make an update now, but when
  41     -- I later return to the old version, I want it to mutate back
  42     -- instead of being copied".
  43
  44     IOToDiffArray, -- data IOToDiffArray
  45                    --     (a :: * -> * -> *) -- internal mutable array
  46                    --     (i :: *)           -- indices
  47                    --     (e :: *)           -- elements
  48
  49     -- | Type synonyms for the two most important IO array types.
  50
  51     -- Two most important diff array types are fully polymorphic
  52     -- lazy boxed DiffArray:
  53     DiffArray,     -- = IOToDiffArray IOArray
  54     -- ...and strict unboxed DiffUArray, working only for elements
  55     -- of primitive types but more compact and usually faster:
  56     DiffUArray,    -- = IOToDiffArray IOUArray
  57
  58     -- * Overloaded immutable array interface
  59
  60     -- | Module "Data.Array.IArray" provides the interface of diff arrays.
  61     -- They are instances of class 'IArray'.
  62     module Data.Array.IArray,
  63
  64     -- * Low-level interface
  65
  66     -- | These are really internal functions, but you will need them
  67     -- to make further 'IArray' instances of various diff array types
  68     -- (for either more 'MArray' types or more unboxed element types).
  69     newDiffArray, readDiffArray, replaceDiffArray
  70     )
  71     where
  72
  73 ------------------------------------------------------------------------
  74 -- Imports.
  75
  76 import Prelude
  77
  78 import Data.Ix
  79 import Data.Array.Base
  80 import Data.Array.IArray
  81 import Data.Array.IO
  82
  83 import Foreign.Ptr        ( Ptr, FunPtr )
  84 import Foreign.StablePtr  ( StablePtr )
  85 import Data.Int           ( Int8,  Int16,  Int32,  Int64 )
  86 #ifdef __GLASGOW_HASKELL__
  87 import Data.Word          ( Word )
  88 #endif
  89 import Data.Word          ( Word8, Word16, Word32, Word64 )
  90
  91 import System.IO.Unsafe   ( unsafePerformIO )
  92 import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, readMVar )
  93
  94 ------------------------------------------------------------------------
  95 -- Diff array types.
  96
  97 -- | An arbitrary 'MArray' type living in the 'IO' monad can be converted
  98 -- to a diff array.
  99
 100 newtype IOToDiffArray a i e =
 101     DiffArray {varDiffArray :: MVar (DiffArrayData a i e)}
 102
 103 -- Internal representation: either a mutable array, or a link to
 104 -- another diff array patched with a list of index+element pairs.
 105 data DiffArrayData a i e = Current (a i e)
 106                          | Diff (IOToDiffArray a i e) [(Int, e)]
 107
 108 -- | Fully polymorphic lazy boxed diff array.
 109 type DiffArray  = IOToDiffArray IOArray
 110
 111 -- | Strict unboxed diff array, working only for elements
 112 -- of primitive types but more compact and usually faster than 'DiffArray'.
 113 type DiffUArray = IOToDiffArray IOUArray
 114
 115 -- Having 'MArray a e IO' in instance context would require
 116 -- -fallow-undecidable-instances, so each instance is separate here.
 117
 118 ------------------------------------------------------------------------
 119 -- Showing DiffArrays
 120
 121 instance (Ix ix, Show ix, Show e) => Show (DiffArray ix e) where
 122   showsPrec = showsIArray
 123
 124 instance (Ix ix, Show ix) => Show (DiffUArray ix Char) where
 125   showsPrec = showsIArray
 126
 127 instance (Ix ix, Show ix) => Show (DiffUArray ix Int) where
 128   showsPrec = showsIArray
 129
 130 #ifdef __GLASGOW_HASKELL__
 131 instance (Ix ix, Show ix) => Show (DiffUArray ix Word) where
 132   showsPrec = showsIArray
 133 #endif
 134
 135 instance (Ix ix, Show ix) => Show (DiffUArray ix Float) where
 136   showsPrec = showsIArray
 137
 138 instance (Ix ix, Show ix) => Show (DiffUArray ix Double) where
 139   showsPrec = showsIArray
 140
 141 instance (Ix ix, Show ix) => Show (DiffUArray ix Int8) where
 142   showsPrec = showsIArray
 143
 144 instance (Ix ix, Show ix) => Show (DiffUArray ix Int16) where
 145   showsPrec = showsIArray
 146
 147 instance (Ix ix, Show ix) => Show (DiffUArray ix Int32) where
 148   showsPrec = showsIArray
 149
 150 instance (Ix ix, Show ix) => Show (DiffUArray ix Int64) where
 151   showsPrec = showsIArray
 152
 153 instance (Ix ix, Show ix) => Show (DiffUArray ix Word8) where
 154   showsPrec = showsIArray
 155
 156 instance (Ix ix, Show ix) => Show (DiffUArray ix Word16) where
 157   showsPrec = showsIArray
 158
 159 instance (Ix ix, Show ix) => Show (DiffUArray ix Word32) where
 160   showsPrec = showsIArray
 161
 162 instance (Ix ix, Show ix) => Show (DiffUArray ix Word64) where
 163   showsPrec = showsIArray
 164
 165 ------------------------------------------------------------------------
 166 -- Boring instances.
 167
 168 instance HasBounds a => HasBounds (IOToDiffArray a) where
 169     bounds a = unsafePerformIO $ boundsDiffArray a
 170
 171 instance IArray (IOToDiffArray IOArray) e where
 172     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 173     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 174     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 175
 176 instance IArray (IOToDiffArray IOUArray) Char where
 177     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 178     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 179     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 180
 181 instance IArray (IOToDiffArray IOUArray) Int where
 182     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 183     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 184     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 185
 186 #ifdef __GLASGOW_HASKELL__
 187 instance IArray (IOToDiffArray IOUArray) Word where
 188     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 189     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 190     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 191 #endif
 192
 193 instance IArray (IOToDiffArray IOUArray) (Ptr a) where
 194     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 195     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 196     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 197
 198 instance IArray (IOToDiffArray IOUArray) (FunPtr a) where
 199     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 200     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 201     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 202
 203 instance IArray (IOToDiffArray IOUArray) Float where
 204     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 205     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 206     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 207
 208 instance IArray (IOToDiffArray IOUArray) Double where
 209     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 210     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 211     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 212
 213 instance IArray (IOToDiffArray IOUArray) (StablePtr a) where
 214     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 215     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 216     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 217
 218 instance IArray (IOToDiffArray IOUArray) Int8 where
 219     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 220     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 221     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 222
 223 instance IArray (IOToDiffArray IOUArray) Int16 where
 224     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 225     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 226     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 227
 228 instance IArray (IOToDiffArray IOUArray) Int32 where
 229     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 230     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 231     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 232
 233 instance IArray (IOToDiffArray IOUArray) Int64 where
 234     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 235     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 236     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 237
 238 instance IArray (IOToDiffArray IOUArray) Word8 where
 239     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 240     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 241     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 242
 243 instance IArray (IOToDiffArray IOUArray) Word16 where
 244     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 245     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 246     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 247
 248 instance IArray (IOToDiffArray IOUArray) Word32 where
 249     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 250     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 251     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 252
 253 instance IArray (IOToDiffArray IOUArray) Word64 where
 254     unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies
 255     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
 256     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 257
 258
 259
 260 ------------------------------------------------------------------------
 261 -- The important stuff.
 262
 263 newDiffArray :: (MArray a e IO, Ix i)
 264              => (i,i)
 265              -> [(Int, e)]
 266              -> IO (IOToDiffArray a i e)
 267 newDiffArray (l,u) ies = do
 268     a <- newArray_ (l,u)
 269     sequence_ [unsafeWrite a i e | (i, e) <- ies]
 270     var <- newMVar (Current a)
 271     return (DiffArray var)
 272
 273 readDiffArray :: (MArray a e IO, Ix i)
 274               => IOToDiffArray a i e
 275               -> Int
 276               -> IO e
 277 a `readDiffArray` i = do
 278     d <- readMVar (varDiffArray a)
 279     case d of
 280         Current a'  -> unsafeRead a' i
 281         Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies)
 282
 283 replaceDiffArray :: (MArray a e IO, Ix i)
 284                 => IOToDiffArray a i e
 285                 -> [(Int, e)]
 286                 -> IO (IOToDiffArray a i e)
 287 a `replaceDiffArray` ies = do
 288     d <- takeMVar (varDiffArray a)
 289     case d of
 290         Current a' -> case ies of
 291             [] -> do
 292                 -- We don't do the copy when there is nothing to change
 293                 -- and this is the current version. But see below.
 294                 putMVar (varDiffArray a) d
 295                 return a
 296             _:_ -> do
 297                 diff <- sequence [do e <- unsafeRead a' i; return (i, e)
 298                                   | (i, _) <- ies]
 299                 sequence_ [unsafeWrite a' i e | (i, e) <- ies]
 300                 var' <- newMVar (Current a')
 301                 putMVar (varDiffArray a) (Diff (DiffArray var') diff)
 302                 return (DiffArray var')
 303         Diff _ _ -> do
 304             -- We still do the copy when there is nothing to change
 305             -- but this is not the current version. So you can use
 306             -- 'a // []' to make sure that the resulting array has
 307             -- fast element access.
 308             putMVar (varDiffArray a) d
 309             a' <- thawDiffArray a
 310                 -- thawDiffArray gives a fresh array which we can
 311                 -- safely mutate.
 312             sequence_ [unsafeWrite a' i e | (i, e) <- ies]
 313             var' <- newMVar (Current a')
 314             return (DiffArray var')
 315
 316 boundsDiffArray :: (HasBounds a, Ix ix)
 317                 => IOToDiffArray a ix e
 318                 -> IO (ix,ix)
 319 boundsDiffArray a = do
 320     d <- readMVar (varDiffArray a)
 321     case d of
 322         Current a' -> return (bounds a')
 323         Diff a' _  -> boundsDiffArray a'
 324
 325 freezeDiffArray :: (MArray a e IO, Ix ix)
 326                 => a ix e
 327                 -> IO (IOToDiffArray a ix e)
 328 freezeDiffArray a = case bounds a of
 329   (l,u) -> do
 330     a' <- newArray_ (l,u)
 331     sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize (l,u) - 1]]
 332     var <- newMVar (Current a')
 333     return (DiffArray var)
 334
 335 {-# RULES
 336 "freeze/DiffArray" freeze = freezeDiffArray
 337     #-}
 338
 339 -- unsafeFreezeDiffArray is really unsafe. Better don't use the old
 340 -- array at all after freezing. The contents of the source array will
 341 -- be changed when '//' is applied to the resulting array.
 342
 343 unsafeFreezeDiffArray :: (MArray a e IO, Ix ix)
 344                       => a ix e
 345                       -> IO (IOToDiffArray a ix e)
 346 unsafeFreezeDiffArray a = do
 347     var <- newMVar (Current a)
 348     return (DiffArray var)
 349
 350 {-# RULES
 351 "unsafeFreeze/DiffArray" unsafeFreeze = unsafeFreezeDiffArray
 352     #-}
 353
 354 thawDiffArray :: (MArray a e IO, Ix ix)
 355               => IOToDiffArray a ix e
 356               -> IO (a ix e)
 357 thawDiffArray a = do
 358     d <- readMVar (varDiffArray a)
 359     case d of
 360         Current a' -> case bounds a' of
 361           (l,u) -> do
 362             a'' <- newArray_ (l,u)
 363             sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize (l,u) - 1]]
 364             return a''
 365         Diff a' ies -> do
 366             a'' <- thawDiffArray a'
 367             sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
 368             return a''
 369
 370 {-# RULES
 371 "thaw/DiffArray" thaw = thawDiffArray
 372     #-}
 373
 374 -- unsafeThawDiffArray is really unsafe. Better don't use the old
 375 -- array at all after thawing. The contents of the resulting array
 376 -- will be changed when '//' is applied to the source array.
 377
 378 unsafeThawDiffArray :: (MArray a e IO, Ix ix)
 379                     => IOToDiffArray a ix e
 380                     -> IO (a ix e)
 381 unsafeThawDiffArray a = do
 382     d <- readMVar (varDiffArray a)
 383     case d of
 384         Current a'  -> return a'
 385         Diff a' ies -> do
 386             a'' <- unsafeThawDiffArray a'
 387             sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
 388             return a''
 389
 390 {-# RULES
 391 "unsafeThaw/DiffArray" unsafeThaw = unsafeThawDiffArray
 392     #-}