ghc/lib/prelude/IArray.hs

   1 -- *** all of PreludeArray except the actual data decls
   2
   3 module PreludeArray (
   4         Array, Assoc,
   5
   6         (!),
   7         (//),
   8         accum,
   9         accumArray,
  10         amap,
  11         array,
  12         assocs,
  13         bounds,
  14         elems,
  15         indices,
  16         ixmap,
  17         listArray
  18     ) where
  19
  20 import Cls
  21 import Core
  22 import IChar
  23 import IInt             -- instances
  24 import IDouble
  25 import IList
  26 import ITup2
  27 import List             ( (++), zipWith, foldr )
  28 import Prel             ( (&&), (.) )
  29 import PS               ( _PackedString, _unpackPS )
  30 import Text
  31 import TyArray          ( Array(..), Assoc(..) )
  32 import TyComplex
  33 import PreludeGlaST
  34
  35 -- Hey! This isn't wimp Haskell-report code!  This is
  36 -- the Business End of Arrays...
  37
  38 --infixl 9  !
  39 --infixl 9  //
  40 --infix  1  :=
  41
  42 -----------------------------------------------------------
  43 instance (Eq a, Eq b) => Eq (Assoc a b) where
  44     (a1 := b1) == (a2 := b2) = a1 == a2 && b1 == b2
  45     a /= b                   = if a == b then False else True
  46
  47 instance (Ord a, Ord b) => Ord (Assoc a b) where
  48     a <  b  = case _tagCmp a b of { _LT -> True;  _EQ -> False; _GT -> False }
  49     a <= b  = case _tagCmp a b of { _LT -> True;  _EQ -> True;  _GT -> False }
  50     a >= b  = case _tagCmp a b of { _LT -> False; _EQ -> True;  _GT -> True  }
  51     a >  b  = case _tagCmp a b of { _LT -> False; _EQ -> False; _GT -> True  }
  52     max a b = case _tagCmp a b of { _LT -> b; _EQ -> a;  _GT -> a }
  53     min a b = case _tagCmp a b of { _LT -> a; _EQ -> a;  _GT -> b }
  54     _tagCmp (a1 := b1) (a2 := b2)
  55       = case (_tagCmp a1 a2) of { _LT -> _LT; _GT -> _GT; _EQ -> _tagCmp b1 b2 }
  56
  57 instance (Ix a, Ix b) => Ix (Assoc a b) where
  58     range (l1 := l2, u1 := u2)
  59       = [ (i1 := i2) | i1 <- range (l1, u1), i2 <- range (l2, u2) ]
  60
  61     index (l1 := l2, u1 := u2) (i1 := i2)
  62       = index (l1, u1) i1 * (index (l2, u2) u2 + 1){-rangeSize (l2, u2)-} + index (l2, u2) i2
  63
  64     inRange (l1 := l2, u1 := u2) (i1 := i2)
  65       = inRange (l1, u1) i1 && inRange (l2, u2) i2
  66
  67 instance (Text a, Text b) => Text (Assoc a b) where
  68     -- magic fixity wired in: infix 1 :=
  69     readsPrec p
  70       = readParen ( p > 1 )
  71           (\ r -> [ (x := y, s2) | (x,    s0) <- readsPrec 2 r,
  72                                    (":=", s1) <- lex s0,
  73                                    (y,    s2) <- readsPrec 2 s1 ])
  74     showsPrec d (a := b)
  75       = showParen (d > 1)
  76           (showsPrec 2 a . showString " := " . showsPrec 2 b)
  77
  78     readList = _readList (readsPrec 0)
  79     showList = _showList (showsPrec 0)
  80
  81 -- ToDo: *** Binary
  82
  83 -----------------------------------------------------------
  84
  85 type IPr = (Int, Int)
  86
  87 {-# GENERATE_SPECS array a{~,Int,IPr} b{} #-}
  88 array       :: (Ix a) => (a,a) -> [Assoc a b] -> Array a b
  89
  90 {-# GENERATE_SPECS (!) a{~,Int,IPr} b{} #-}
  91 (!)         :: (Ix a) => Array a b -> a -> b
  92
  93 bounds      :: Array a b -> (a,a)
  94
  95 {-# GENERATE_SPECS listArray a{~,Int,IPr} b{} #-}
  96 listArray   :: (Ix a) => (a,a) -> [b] -> Array a b
  97
  98 {-# GENERATE_SPECS indices a{~,Int,IPr} b{} #-}
  99 indices     :: (Ix a) => Array a b -> [a]
 100
 101 {-# GENERATE_SPECS elems a{~,Int,IPr} b{} #-}
 102 elems       :: (Ix a) => Array a b -> [b]
 103
 104 {-# GENERATE_SPECS assocs a{~,Int,IPr} b{} #-}
 105 assocs      :: (Ix a) => Array a b -> [Assoc a b]
 106
 107 {-# GENERATE_SPECS accumArray a{~,Int,IPr} b{} c{} #-}
 108 accumArray  :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [Assoc a c] -> Array a b
 109
 110 {-# GENERATE_SPECS (//) a{~,Int,IPr} b{} #-}
 111 (//)        :: (Ix a) => Array a b -> [Assoc a b] -> Array a b
 112
 113 {-# GENERATE_SPECS accum a{~,Int,IPr} b{} c{} #-}
 114 accum       :: (Ix a) => (b -> c -> b) -> Array a b -> [Assoc a c] -> Array a b
 115
 116 {-# GENERATE_SPECS amap a{~,Int,IPr} b{} c{} #-}
 117 amap        :: (Ix a) => (b -> c) -> Array a b -> Array a c
 118
 119 ixmap       :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
 120
 121
 122 {- "array", "!" and "bounds" are basic;
 123    the rest can be defined in terms of them
 124 -}
 125
 126 bounds (_Array b _)  = b
 127
 128 array ixs@(ix_start, ix_end) ivs
 129   = _runST (
 130         newArray ixs arrEleBottom       `thenStrictlyST` \ arr# ->
 131         fill_it_in arr# ivs             `seqStrictlyST`
 132         freezeArray arr#
 133     )
 134   where
 135     arrEleBottom = error "(!){PreludeArray}: undefined array element"
 136
 137 (_Array bounds arr#) ! i
 138   = let n# = case (index bounds i) of { I# x -> x } -- index fails if out of range
 139     in
 140     case (indexArray# arr# n#) of
 141       _Lift v -> v
 142
 143 fill_it_in arr lst s
 144   = foldr fill_one_in (returnStrictlyST ()) lst s
 145   where  -- **** STRICT **** (but that's OK...)
 146     fill_one_in (i := v) rst s
 147       = (writeArray arr i v `seqStrictlyST` rst) s
 148
 149 {- the rest ------------------------------------------------- -}
 150
 151 listArray b vs        = array b (zipWith (:=) (range b) vs)
 152
 153 indices a             = range (bounds a)
 154
 155 elems a               = [a!i | i <- indices a]
 156
 157 assocs a              = [i := a!i | i <- indices a]
 158
 159 #ifdef USE_REPORT_PRELUDE
 160 a // us               = array (bounds a)
 161                             ([i := a!i | i <- indices a \\ [i | i:=_ <- us]]
 162                              ++ us)
 163
 164 accum f               = foldl (\a (i := v) -> a // [i := f (a!i) v])
 165
 166 accumArray f z b      = accum f (array b [i := z | i <- range b])
 167
 168 #else /* ! USE_REPORT_PRELUDE */
 169
 170 old_array // ivs
 171   = _runST (
 172         -- copy the old array:
 173         newArray (bounds old_array) bottom  `thenStrictlyST` \ arr# ->
 174         fill_it_in arr# (assocs old_array)  `seqStrictlyST`
 175         -- now write the new elements into the new array:
 176         fill_it_in arr# ivs                 `seqStrictlyST`
 177         freezeArray arr#
 178     )
 179   where
 180     bottom = error "(//){PreludeArray}: error in copying old array\n"
 181
 182 -- zap_with_f: reads an elem out first, then uses "f" on that and the new value
 183
 184 zap_with_f f arr lst s
 185   = foldr zap_one (returnStrictlyST ()) lst s
 186   where
 187     zap_one (i := new_v) rst s
 188       = (readArray  arr i                `thenStrictlyST`  \ old_v ->
 189         writeArray arr i (f old_v new_v) `seqStrictlyST`
 190         rst) s
 191
 192 accum f arr ivs
 193   = _runST (
 194         -- copy the old array:
 195         newArray (bounds arr) bottom    `thenST` \ arr# ->
 196         fill_it_in arr# (assocs arr)    `seqST`
 197
 198         -- now zap the elements in question with "f":
 199         zap_with_f f arr# ivs           `seqST`
 200         freezeArray arr#
 201     )
 202   where
 203     bottom = error "accum{PreludeArray}: error in copying old array\n"
 204
 205 accumArray f zero ixs ivs
 206   = _runST (
 207         newArray ixs zero       `thenST` \ arr# ->
 208         zap_with_f f  arr# ivs  `seqST`
 209         freezeArray arr#
 210     )
 211 #endif /* ! USE_REPORT_PRELUDE */
 212
 213 amap f a              = array b [i := f (a!i) | i <- range b]
 214                         where b = bounds a
 215
 216 ixmap b f a           = array b [i := a ! f i | i <- range b]
 217
 218 instance (Ix a, Eq b)   => Eq (Array a b)  where
 219     a == a'  =  assocs a == assocs a'
 220     a /= a'  =  assocs a /= assocs a'
 221
 222 instance (Ix a, Ord b) => Ord (Array a b) where
 223     a <  b  = case _tagCmp a b of { _LT -> True;  _EQ -> False; _GT -> False }
 224     a <= b  = case _tagCmp a b of { _LT -> True;  _EQ -> True;  _GT -> False }
 225     a >= b  = case _tagCmp a b of { _LT -> False; _EQ -> True;  _GT -> True  }
 226     a >  b  = case _tagCmp a b of { _LT -> False; _EQ -> False; _GT -> True  }
 227
 228     max a b = case _tagCmp a b of { _LT -> b; _EQ -> a;  _GT -> a }
 229     min a b = case _tagCmp a b of { _LT -> a; _EQ -> a;  _GT -> b }
 230
 231     _tagCmp a b = _tagCmp (assocs a) (assocs b)
 232
 233 instance  (Ix a, Text a, Text b) => Text (Array a b)  where
 234     showsPrec p a = showParen (p > 9) (
 235                     showString "array " .
 236                     showsPrec 0 (bounds a) . showChar ' ' .
 237                     showList (assocs a) )
 238
 239     readsPrec p = readParen (p > 9)
 240            (\r -> [(array b as, u) | ("array",s) <- lex r,
 241                                      (b,t)       <- readsPrec 0 s,
 242                                      (as,u)      <- readList t ]
 243                   ++
 244                   [(listArray b xs, u) | ("listArray",s) <- lex r,
 245                                          (b,t)           <- readsPrec 0 s,
 246                                          (xs,u)          <- readList t ])
 247
 248     readList = _readList (readsPrec 0)
 249     showList = _showList (showsPrec 0)
 250
 251
 252 {-# SPECIALIZE instance Text (Array Int Double) #-}
 253 {-# SPECIALIZE instance Text (Array (Int,Int) Double) #-}
 254
 255 {- **** OMITTED **** (ToDo)
 256 instance  (Ix a, Binary a, Binary b) => Binary (Array a b)  where
 257     showBin a = showBin (bounds a) . showBin (elems a)
 258
 259     readBin bin = (listArray b vs, bin'')
 260                  where (b,bin')   = readBin bin
 261                        (vs,bin'') = readBin bin'
 262 -}
 263 {- ToDo ...
 264
 265 #if defined(__UNBOXED_INSTANCES__)
 266
 267 -- {-# GENERATE_SPECS array a{~,Int#,Int,IPr} b{Int#,Double#} #-}
 268 -- {-# GENERATE_SPECS (!) a{~,Int#,Int,IPr} b{Int#,Double#} #-}
 269 -- {-# GENERATE_SPECS bounds a{~,Int#} b{Int#,Double#} #-}
 270 -- {-# GENERATE_SPECS listArray a{~,Int#,Int,IPr} b{Int#,Double#} #-}
 271 -- {-# GENERATE_SPECS indices a{~,Int#,Int,IPr} b{Int#,Double#} #-}
 272 -- {-# GENERATE_SPECS elems a{~,Int#,Int,IPr} b{Int#,Double#} #-}
 273 -- {-# GENERATE_SPECS assocs a{~,Int#,Int,IPr} b{Int#,Double#} #-}
 274 -- {-# GENERATE_SPECS accumArray a{~,Int#,Int,IPr} b{Int#,Double#} c{Int#,Double#} #-}
 275 -- {-# GENERATE_SPECS (//) a{~,Int#,Int,IPr} b{Int#,Double#} #-}
 276 -- {-# GENERATE_SPECS accum a{~,Int#,Int,IPr} b{Int#,Double#} c{Int#,Double#} #-}
 277 -- {-# GENERATE_SPECS amap a{~,Int#,Int,IPr} b{Int#,Double#} c{Int#,Double#} #-}
 278 -- {-# GENERATE_SPECS ixmap a{~,Int#,Int} b{~,Int#,Int} c{Int#,Double#} #-}
 279
 280 -- {-# GENERATE_SPECS instance a{Int#} b{Int#,Double#} :: Eq (Array a b) #-}
 281 -- {-# GENERATE_SPECS instance a{Int#} b{Int#,Double#} :: Ord (Array a b) #-}
 282 -- {-# GENERATE_SPECS instance a{Int#} b{Int#,Double#} :: Text (Array a b) #-}
 283
 284 -- {-# GENERATE_SPECS instance a{Int#} b{Int#,Double#} :: Eq (Assoc a b) #-}
 285 -- {-# GENERATE_SPECS instance a{Int#} b{Int#,Double#} :: Ord (Assoc a b) #-}
 286 -- {-# GENERATE_SPECS instance a{Int#} b{Int#,Double#} :: Ix (Assoc a b) #-}
 287 -- {-# GENERATE_SPECS instance a{Int#} b{Int#,Double#} :: Text (Assoc a b) #-}
 288
 289 #endif
 290
 291 -}