Bump `base` version to 4.9.0.0 (closes #11026)
[ghc.git] / testsuite / tests / typecheck / should_fail / tcfail068.hs
1 -- !! Make sure that state threads don't escape
2 -- !! (example from Neil Ashton at York)
3 --
4 module ShouldFail where
5
6 import GHC.Arr
7 import Control.Monad.ST ( runST )
8
9 type IndTree s t = STArray s (Int,Int) t
10
11 itgen :: Constructed a => (Int,Int) -> a -> IndTree s a
12 itgen n x =
13 runST (
14 newSTArray ((1,1),n) x)
15
16 itiap :: Constructed a => (Int,Int) -> (a->a) -> IndTree s a -> IndTree s a
17 itiap i f arr =
18 runST (
19 readSTArray arr i >>= \val ->
20 writeSTArray arr i (f val) >>
21 return arr)
22
23 itrap :: Constructed a => ((Int,Int),(Int,Int)) -> (a->a) -> IndTree s a -> IndTree s a
24 itrap ((i,k),(j,l)) f arr = runST (itrap' i k)
25 where
26 itrap' i k = if k > l then return arr
27 else (itrapsnd i k >>
28 itrap' i (k+1))
29 itrapsnd i k = if i > j then return arr
30 else (readSTArray arr (i,k) >>= \val ->
31 writeSTArray arr (i,k) (f val) >>
32 itrapsnd (i+1) k)
33
34 itrapstate :: Constructed b => ((Int,Int),(Int,Int)) -> (a->b->(a,b)) -> ((Int,Int)->c->a) ->
35 (a->c) -> c -> IndTree s b -> (c, IndTree s b)
36 itrapstate ((i,k),(j,l)) f c d s arr = runST(itrapstate' i k s)
37 where
38 itrapstate' i k s = if k > l then return (s,arr)
39 else (itrapstatesnd i k s >>= \(s,arr) ->
40 itrapstate' i (k+1) s)
41 itrapstatesnd i k s = if i > j then return (s,arr)
42 else (readSTArray arr (i,k) >>= \val ->
43 let (newstate, newval) = f (c (i,k) s) val
44 in writeSTArray arr (i,k) newval >>
45 itrapstatesnd (i+1) k (d newstate))
46
47 -- stuff from Auxiliary: copied here (partain)
48
49 sap :: (a->b) -> (c,a) -> (c,b)
50 sap f (x,y) = (x, f y)
51
52 fap :: (a->b) -> (a,c) -> (b,c)
53 fap f (x,y) = (f x, y)
54
55 nonempty :: [a] -> Bool
56 nonempty [] = False
57 nonempty (_:_) = True
58
59 -- const :: a -> b -> a
60 -- const k x = k
61
62 -- id :: a -> a
63 -- id x = x
64
65 compose :: [a->a] -> a -> a
66 compose = foldr (.) id
67
68 class Constructed a where
69 normal :: a -> Bool
70
71 instance Constructed Bool where
72 normal True = True
73 normal False = True
74
75 instance Constructed Int where
76 normal 0 = True
77 normal n = True
78
79 instance (Constructed a, Constructed b) => Constructed (a,b) where
80 normal (x,y) = normal x && normal y
81
82 -- pair :: (Constructed a, Constructed b) => a -> b -> (a,b)
83 -- pair x y | normal x && normal y = (x,y)
84
85 instance Constructed (Maybe a) where
86 normal Nothing = True
87 normal (Just _) = True
88
89 just :: Constructed a => a -> Maybe a
90 just x | normal x = Just x