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