Ticket #7828: bug-arrow.hs

File bug-arrow.hs, 2.4 KB (added by AlessandroVermeulen, 7 years ago)
Line 
1{-# LANGUAGE GADTs, Arrows #-}
2{-# LANGUAGE RebindableSyntax #-}
3module Main where
4
5import Prelude          (Either(..), flip, Int, return)
6
7import Control.Category (Category)
8import Control.Arrow    (Arrow)
9
10import Data.Typeable
11
12-- Arrow
13
14test :: Typeable a => R a a
15test = proc n -> returnA -< n
16--test =
17--    (>>>)
18--      (arr (\ (n_apd) -> n_apd))
19--      ((>>>)
20--         (arr (\ (ds_dst) -> ds_dst))
21--         (returnA)
22--         )
23
24
25--test2 :: (Typeable a) => R a a
26--test2 = returnA
27
28instance Category R where
29instance Arrow R where
30
31-- Data definitions
32
33--data R a b where
34--  Id       :: ()--(Typeable a)             
35--           => R a a
36--  Comp     :: ()--(Typeable a, Typeable b, Typeable c)
37--           => R b c -> R a b -> R a c
38--  Arr      :: ()--(Typeable a, Typeable b)
39--           => (a -> b) -> R a b
40--  Split    :: ()--(Typeable b, Typeable b', Typeable c, Typeable c')
41--           => R b c    -> R b' c'        -> R (b,b') (c,c')
42--  Choice   :: ()--(Typeable b, Typeable b', Typeable c, Typeable c')
43--           => R b c -> R b' c' -> R (Either b b') (Either c c')
44
45data R a b where
46  Id       :: (Typeable a)             
47           => R a a
48  Comp     :: (Typeable a, Typeable b, Typeable c)
49           => R b c -> R a b -> R a c
50  Arr      :: (Typeable a, Typeable b)
51           => (a -> b) -> R a b
52  Split    :: (Typeable b, Typeable b', Typeable c, Typeable c')
53           => R b c    -> R b' c'        -> R (b,b') (c,c')
54  Choice   :: (Typeable b, Typeable b', Typeable c, Typeable c')
55           => R b c -> R b' c' -> R (Either b b') (Either c c')
56
57
58-- Arrow stuff
59infixr 1 >>>
60infixr 3 ***
61infixr 2 +++
62
63
64
65--arr :: (Typeable a, Typeable b) => (a -> b) -> R a b
66arr :: (Typeable a, Typeable b) 
67    => (a -> b) -> R a b
68arr = Arr
69
70first :: (Typeable b, Typeable c, Typeable d)
71      => R b c -> R (b, d) (c, d)
72first = (*** Id) 
73
74second :: (Typeable b, Typeable c, Typeable d)
75       => R b c -> R (d, b) (d, c)
76second = (Id ***) 
77
78(***) ::  (Typeable b, Typeable b', Typeable c, Typeable c')
79      => R b c    -> R b' c'        -> R (b,b') (c,c')
80(***) = Split
81
82(+++) :: (Typeable b, Typeable b', Typeable c, Typeable c')
83      => R b c -> R b' c' -> R (Either b b') (Either c c')
84(+++)   = Choice
85
86(>>>) :: (Typeable a, Typeable b, Typeable c)
87      => R a b -> R b c -> R a c
88(>>>) = flip Comp
89
90returnA :: Typeable a
91        => R a a
92returnA = Id
93
94main = return ()