1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
import Data.STRef.Lazy
import Control.Monad.ST.Lazy as L
import Control.Monad.ST.Strict as S
import qualified Data.STRef as S
import Data.Function (fix)
import System.IO (hPutStrLn, stderr)
import Debug.Trace (trace)
-- The following implements `fix` using lazy `ST`. It is based on code
-- by Oleg Kiselyov (source: http://okmij.org/ftp/Haskell/Fix.hs) which is
-- in the public domain according to the main page (http://okmij.org/ftp/).
fact :: (Int -> Int) -> Int -> Int
fact self 0 = 1
fact self n = n * self (pred n)
-- Test liftM style (Oleg's original style)
fix1 :: (a -> a) -> a
fix1 f = L.runST $ do
wrap <- newSTRef (error "black hole")
let aux = readSTRef wrap >>= (\x -> x >>= pure . f)
writeSTRef wrap aux
aux
-- Test fmap style
fix2 :: (a -> a) -> a
fix2 f = L.runST $ do
wrap <- newSTRef (error "black hole")
let aux = readSTRef wrap >>= \x -> f <$> x
writeSTRef wrap aux
aux
-- The following examples are by Albert Y. C. Lai, and included (under the
-- GHC license) with his permission:
-- https://mail.haskell.org/pipermail/haskell-cafe/2017-January/126182.html
example1 :: [Int]
example1 = L.runST go where
go = do
v <- strictToLazyST (S.newSTRef 0)
fix (\loop -> do
n <- strictToLazyST (do n <- S.readSTRef v
S.writeSTRef v (n+1)
return n
)
ns <- loop
return (n : ns))
example2 :: [Int]
example2 = L.runST main where
main = do
v <- strictToLazyST (S.newSTRef 0)
sequence (repeat (strictToLazyST (do n <- S.readSTRef v
S.writeSTRef v (n+1)
return n
)))
example3 :: L.ST s [Integer]
example3 = do
r <- newSTRef 0
let loop = do
x <- readSTRef r
writeSTRef r $ x + 1
xs <- loop
writeSTRef r $ x + 2
return $ x : xs
loop
example4 :: L.ST s [Integer]
example4 = do
r <- newSTRef 0
let loop = do
x <- readSTRef r
writeSTRef r $ x + 1
xs <- loop
error "this line is dead code"
return $ x : xs
loop
star n s = trace ("<" ++ s ++ show n ++ ">") (return ())
-- Albert called this "Sprinkle sprinkle little stars, how
-- I wonder when you are"
example5 :: L.ST s [Integer]
example5 = do
star 0 "init begin"
r <- newSTRef 0
star 0 "init end"
let loop n = do
star n "A"
x <- readSTRef r
star n "B"
writeSTRef r $ x + 1
star n "C"
xs <- loop (n+1)
star n "D"
writeSTRef r $ x + 2
star n "E"
return $ x : xs
loop 0
main :: IO ()
main = do
print $ fix1 fact 5
print $ fix2 fact 6
print $ take 5 example1
print $ take 5 example2
print $ take 10 (L.runST example3)
print $ take 10 (L.runST example4)
hPutStrLn stderr $ show (take 5 (L.runST example5))
|
