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