Fix #17334 where NCG did not properly update the CFG.
[ghc.git] / testsuite / tests / typecheck / should_compile / tc192.hs
1 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2 {-# LANGUAGE Arrows, CPP, TypeOperators #-}
3
4 -- Test infix type notation and arrow notation
5
6 module Test where
7
8 import Prelude hiding (id,(.))
9 import Control.Category
10 import Control.Arrow
11
12 -- For readability, I use infix notation for arrow types. I'd prefer the
13 -- following, but GHC doesn't allow operators like "-=>" as type
14 -- variables.
15 --
16 -- comp1 :: Arrow (-=>) => b-=>c -> c-=>d -> b-=>d
17
18
19 comp1 :: Arrow to => b `to` c -> c `to` d -> b `to` d
20 comp1 f g = proc x -> do
21 b <- f -< x
22 g -< b
23
24 -- arrowp produces
25 -- comp1 f g = (f >>> g)
26
27 comp :: Arrow to => (b `to` c, c `to` d) `to` (b `to` d)
28 comp = arr (uncurry (>>>))
29
30 -- app :: Arrow to => (b c, b) `to` c
31
32 type R = Float
33 type I = Int
34
35 z1,z2 :: Arrow to => I `to` (R `to` R)
36 z1 = undefined
37 z2 = z1
38
39 z3 :: Arrow to => (I,I) `to` (R `to` R,R `to` R)
40 z3 = z1 *** z2
41
42 z4 :: Arrow to => (I,I) `to` (R `to` R)
43 z4 = z3 >>> comp
44
45 comp4,comp5 :: Arrow to =>
46 b `to` (c `to` d) -> e `to` (d `to` f) -> (b,e) `to` (c `to` f)
47
48 comp4 g f = proc (b,e) -> do
49 g' <- g -< b
50 f' <- f -< e
51 returnA -< (g' >>> f')
52
53 comp5 g f = (g *** f) >>> comp
54
55 lam,lam2 :: Arrow to => (e,b) `to` c -> e `to` (b `to` c)
56
57 lam f = arr $ \ e -> arr (pair e) >>> f
58
59 pair a b = (a,b)
60
61 -- I got the definition lam above by starting with
62
63 lam2 f = proc e ->
64 returnA -< (proc b -> do
65 c <- f -< (e,b)
66 returnA -< c)
67
68 -- I desugared with the arrows preprocessor, removed extra parens and
69 -- renamed "arr" to "pure", to get
70 --
71 -- lam f = pure (\ e -> pure (\ b -> (e, b)) >>> f)
72
73 -- Note that lam is arrow curry
74
75 -- curry :: ((e,b) -> c) -> (e -> b -> c)
76
77 -- All equivalent:
78
79 curry1 f e b = f (e,b)
80
81 curry2 f = \ e -> \ b -> f (e,b)
82
83 curry3 f = \ e -> f . (\ b -> (e,b))
84
85 curry4 f = \ e -> f . (pair e)
86
87
88
89 comp6 :: Arrow to => b `to` (c `to` d) -> e `to` (d `to` f)
90 -> b `to` (e `to` (c `to` f))
91 comp6 g f = lam $ comp5 g f
92
93 -- What about uncurrying?
94
95 -- uncurryA :: Arrow to => b `to` (c `to` d)
96 -- -> (b,c) `to` d
97 -- uncurryA f = proc (b,c) -> do
98 -- f' <- f -< b
99 -- returnA -< f' c
100
101 -- Why "lam" instead of "curryA" (good name also): so I can use Arrows
102 -- lambda notation, similar to
103
104 compF g f = \ b e -> g b . f e
105
106 -- But I haven't figured out how to.
107
108 -- comp7 :: Arrow to => b `to` (c `to` d) -> e `to` (d `to` f)
109 -- -> b `to` (e `to` (c `to` f))
110 -- comp7 g f = proc b -> proc e -> do
111 -- g' <- g -< b
112 -- f' <- f -< e
113 -- returnA -< (g' >>> f')
114
115 -- Try "(| lam \ b -> ... |)" in the FOP arrows chapter
116 -- cmd ::= form exp cmd1 ... cmdn. Parens if nec
117
118 -- (| lam (\ b -> undefined) |)
119
120 -- Oh! The arrow syntax allows bindings with *infix* operators. And I
121 -- don't know how to finish comp7.
122
123 -- Uncurried forms:
124
125 comp8 :: Arrow to => (b,c) `to` d -> (e,d) `to` k -> (b,c,e) `to` k
126 comp8 g f = proc (b,c,e) -> do
127 d <- g -< (b,c)
128 f -< (e,d)
129
130 -- This looks like straightforward `to` translation. With insertions of
131 -- curry & uncurry operators, it'd probably be easy to handle curried
132 -- definitions as well.
133
134 -- Simpler example, for experimentation
135
136 comp9 :: Arrow to => (c,d) `to` e -> b `to` d -> (b,c) `to` e
137 comp9 g f = proc (b,c) -> do
138 d <- f -< b
139 g -< (c,d)
140
141 -- Desugared:
142
143 comp9' :: Arrow to => (c,d) `to` e -> b `to` d -> (b,c) `to` e
144 comp9' g f = first f >>> arr (\ (d,c) -> (c,d)) >>> g
145
146