[project @ 2001-06-28 14:15:04 by simonmar]
[packages/pretty.git] / Control / Monad / ST / Lazy.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Module : Control.Monad.ST.Lazy
4 -- Copyright : (c) The University of Glasgow 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
6 --
7 -- Maintainer : libraries@haskell.org
8 -- Stability : provisional
9 -- Portability : portable
10 --
11 -- $Id: Lazy.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
12 --
13 -- This module presents an identical interface to Control.Monad.ST,
14 -- but the underlying implementation of the state thread is lazy.
15 --
16 -----------------------------------------------------------------------------
17
18 module Control.Monad.ST.Lazy (
19 ST,
20
21 runST,
22 unsafeInterleaveST,
23 fixST,
24
25 STRef.STRef,
26 newSTRef, readSTRef, writeSTRef,
27
28 STArray.STArray,
29 newSTArray, readSTArray, writeSTArray, boundsSTArray,
30 thawSTArray, freezeSTArray, unsafeFreezeSTArray,
31 #ifdef __GLASGOW_HASKELL__
32 -- no 'good' reason, just doesn't support it right now.
33 unsafeThawSTArray,
34 #endif
35
36 ST.unsafeIOToST, ST.stToIO,
37
38 strictToLazyST, lazyToStrictST
39 ) where
40
41 import Prelude
42
43 import qualified Data.STRef as STRef
44 import Data.Array
45
46 #ifdef __GLASGOW_HASKELL__
47 import qualified Control.Monad.ST as ST
48 import qualified GHC.Arr as STArray
49 import qualified GHC.ST
50 import GHC.Base ( ($), ()(..) )
51 import Control.Monad
52 import Data.Ix
53 import GHC.Prim
54 #endif
55
56 #ifdef __HUGS__
57 import qualified ST
58 import Monad
59 import Ix
60 import Array
61 import PrelPrim ( unST
62 , mkST
63 , PrimMutableArray
64 , PrimArray
65 , primNewArray
66 , primReadArray
67 , primWriteArray
68 , primUnsafeFreezeArray
69 , primSizeMutableArray
70 , primSizeArray
71 , primIndexArray
72 )
73 #endif
74
75
76 #ifdef __GLASGOW_HASKELL__
77 newtype ST s a = ST (State s -> (a, State s))
78 data State s = S# (State# s)
79 #endif
80
81 #ifdef __HUGS__
82 newtype ST s a = ST (s -> (a,s))
83 #endif
84
85 instance Functor (ST s) where
86 fmap f m = ST $ \ s ->
87 let
88 ST m_a = m
89 (r,new_s) = m_a s
90 in
91 (f r,new_s)
92
93 instance Monad (ST s) where
94
95 return a = ST $ \ s -> (a,s)
96 m >> k = m >>= \ _ -> k
97 fail s = error s
98
99 (ST m) >>= k
100 = ST $ \ s ->
101 let
102 (r,new_s) = m s
103 ST k_a = k r
104 in
105 k_a new_s
106
107
108 #ifdef __GLASGOW_HASKELL__
109 {-# NOINLINE runST #-}
110 runST :: (forall s. ST s a) -> a
111 runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
112 #endif
113
114 #ifdef __HUGS__
115 runST :: (__forall s. ST s a) -> a
116 runST st = case st of ST the_st -> let (r,_) = the_st realWorld in r
117 where realWorld = error "runST: entered the RealWorld"
118 #endif
119
120 fixST :: (a -> ST s a) -> ST s a
121 fixST m = ST (\ s ->
122 let
123 ST m_r = m r
124 (r,s) = m_r s
125 in
126 (r,s))
127
128 -- ---------------------------------------------------------------------------
129 -- Variables
130
131 newSTRef :: a -> ST s (STRef.STRef s a)
132 readSTRef :: STRef.STRef s a -> ST s a
133 writeSTRef :: STRef.STRef s a -> a -> ST s ()
134
135 newSTRef = strictToLazyST . STRef.newSTRef
136 readSTRef = strictToLazyST . STRef.readSTRef
137 writeSTRef r a = strictToLazyST (STRef.writeSTRef r a)
138
139 -- --------------------------------------------------------------------------
140 -- Arrays
141
142 newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray.STArray s ix elt)
143 readSTArray :: Ix ix => STArray.STArray s ix elt -> ix -> ST s elt
144 writeSTArray :: Ix ix => STArray.STArray s ix elt -> ix -> elt -> ST s ()
145 boundsSTArray :: Ix ix => STArray.STArray s ix elt -> (ix, ix)
146 thawSTArray :: Ix ix => Array ix elt -> ST s (STArray.STArray s ix elt)
147 freezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
148 unsafeFreezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
149
150 #ifdef __GLASGOW_HASKELL__
151
152 newSTArray ixs init = strictToLazyST (STArray.newSTArray ixs init)
153
154 readSTArray arr ix = strictToLazyST (STArray.readSTArray arr ix)
155 writeSTArray arr ix v = strictToLazyST (STArray.writeSTArray arr ix v)
156 boundsSTArray arr = STArray.boundsSTArray arr
157 thawSTArray arr = strictToLazyST (STArray.thawSTArray arr)
158 freezeSTArray arr = strictToLazyST (STArray.freezeSTArray arr)
159 unsafeFreezeSTArray arr = strictToLazyST (STArray.unsafeFreezeSTArray arr)
160 unsafeThawSTArray arr = strictToLazyST (STArray.unsafeThawSTArray arr)
161 #endif
162
163
164 #ifdef __HUGS__
165 newSTArray ixs elt = do
166 { arr <- strictToLazyST (primNewArray (rangeSize ixs) elt)
167 ; return (STArray ixs arr)
168 }
169
170 boundsSTArray (STArray ixs arr) = ixs
171 readSTArray (STArray ixs arr) ix
172 = strictToLazyST (primReadArray arr (index ixs ix))
173 writeSTArray (STArray ixs arr) ix elt
174 = strictToLazyST (primWriteArray arr (index ixs ix) elt)
175 freezeSTArray (STArray ixs arr) = do
176 { arr' <- strictToLazyST (primFreezeArray arr)
177 ; return (Array ixs arr')
178 }
179
180 unsafeFreezeSTArray (STArray ixs arr) = do
181 { arr' <- strictToLazyST (primUnsafeFreezeArray arr)
182 ; return (Array ixs arr')
183 }
184
185 thawSTArray (Array ixs arr) = do
186 { arr' <- strictToLazyST (primThawArray arr)
187 ; return (STArray ixs arr')
188 }
189
190 primFreezeArray :: PrimMutableArray s a -> ST.ST s (PrimArray a)
191 primFreezeArray arr = do
192 { let n = primSizeMutableArray arr
193 ; arr' <- primNewArray n arrEleBottom
194 ; mapM_ (copy arr arr') [0..n-1]
195 ; primUnsafeFreezeArray arr'
196 }
197 where
198 copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
199 arrEleBottom = error "primFreezeArray: panic"
200
201 primThawArray :: PrimArray a -> ST.ST s (PrimMutableArray s a)
202 primThawArray arr = do
203 { let n = primSizeArray arr
204 ; arr' <- primNewArray n arrEleBottom
205 ; mapM_ (copy arr arr') [0..n-1]
206 ; return arr'
207 }
208 where
209 copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
210 arrEleBottom = error "primFreezeArray: panic"
211 #endif
212
213 -- ---------------------------------------------------------------------------
214 -- Strict <--> Lazy
215
216 #ifdef __GLASGOW_HASKELL__
217 strictToLazyST :: ST.ST s a -> ST s a
218 strictToLazyST m = ST $ \s ->
219 let
220 pr = case s of { S# s# -> GHC.ST.liftST m s# }
221 r = case pr of { GHC.ST.STret _ v -> v }
222 s' = case pr of { GHC.ST.STret s2# _ -> S# s2# }
223 in
224 (r, s')
225
226 lazyToStrictST :: ST s a -> ST.ST s a
227 lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
228 case (m (S# s)) of (a, S# s') -> (# s', a #)
229 #endif
230
231 #ifdef __HUGS__
232 strictToLazyST :: ST.ST s a -> ST s a
233 strictToLazyST m = ST $ \s ->
234 let
235 pr = unST m s
236 r = fst pr
237 s' = snd pr
238 in
239 (r, s')
240
241
242 lazyToStrictST :: ST s a -> ST.ST s a
243 lazyToStrictST (ST m) = mkST $ m
244 #endif
245
246 unsafeInterleaveST :: ST s a -> ST s a
247 unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST