1 -- !! Make sure that state threads don't escape
2 -- !! (example from Neil Ashton at York)
4 module ShouldFail where
8 type IndTree s t = STArray s (Int,Int) t
10 itgen :: Constructed a => (Int,Int) -> a -> IndTree s a
13 newSTArray ((1,1),n) x)
15 itiap :: Constructed a => (Int,Int) -> (a->a) -> IndTree s a -> IndTree s a
18 readSTArray arr i >>= \val ->
19 writeSTArray arr i (f val) >>
22 itrap :: Constructed a => ((Int,Int),(Int,Int)) -> (a->a) -> IndTree s a -> IndTree s a
23 itrap ((i,k),(j,l)) f arr = runST(itrap' i k)
25 itrap' i k = if k > l then return arr
28 itrapsnd i k = if i > j then return arr
29 else (readSTArray arr (i,k) >>= \val ->
30 writeSTArray arr (i,k) (f val) >>
33 itrapstate :: Constructed b => ((Int,Int),(Int,Int)) -> (a->b->(a,b)) -> ((Int,Int)->c->a) ->
34 (a->c) -> c -> IndTree s b -> (c, IndTree s b)
35 itrapstate ((i,k),(j,l)) f c d s arr = runST(itrapstate' i k s)
37 itrapstate' i k s = if k > l then return (s,arr)
38 else (itrapstatesnd i k s >>= \(s,arr) ->
39 itrapstate' i (k+1) s)
40 itrapstatesnd i k s = if i > j then return (s,arr)
41 else (readSTArray arr (i,k) >>= \val ->
42 let (newstate, newval) = f (c (i,k) s) val
43 in writeSTArray arr (i,k) newval >>
44 itrapstatesnd (i+1) k (d newstate))
46 -- stuff from Auxiliary: copied here (partain)
48 sap :: (a->b) -> (c,a) -> (c,b)
49 sap f (x,y) = (x, f y)
51 fap :: (a->b) -> (a,c) -> (b,c)
52 fap f (x,y) = (f x, y)
54 nonempty :: [a] -> Bool
58 -- const :: a -> b -> a
64 compose :: [a->a] -> a -> a
65 compose = foldr (.) id
67 class Constructed a where
70 instance Constructed Bool where
74 instance Constructed Int where
78 instance (Constructed a, Constructed b) => Constructed (a,b) where
79 normal (x,y) = normal x && normal y
81 -- pair :: (Constructed a, Constructed b) => a -> b -> (a,b)
82 -- pair x y | normal x && normal y = (x,y)
84 instance Constructed (Maybe a) where
86 normal (Just _) = True
88 just :: Constructed a => a -> Maybe a
89 just x | normal x = Just x