diff options
author | Thomas Miedema <thomasmiedema@gmail.com> | 2016-06-18 22:44:19 +0200 |
---|---|---|
committer | Thomas Miedema <thomasmiedema@gmail.com> | 2016-06-20 16:22:07 +0200 |
commit | 46ff80f26d1892e1b50e3f10c5d3fded33da6e81 (patch) | |
tree | c53fd835b689b6b64a729a42e4cc6482d8fb5215 /testsuite/tests/arrows | |
parent | 7e7094f166b6e475a49e20b98cbca851334aedaf (diff) | |
download | haskell-46ff80f26d1892e1b50e3f10c5d3fded33da6e81.tar.gz |
Testsuite: tabs -> spaces [skip ci]
Diffstat (limited to 'testsuite/tests/arrows')
-rw-r--r-- | testsuite/tests/arrows/should_compile/arrowcase1.hs | 12 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_compile/arrowdo1.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_compile/arrowdo2.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_compile/arrowdo3.hs | 282 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_compile/arrowrec1.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_run/arrowrun001.hs | 30 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_run/arrowrun002.hs | 140 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_run/arrowrun003.hs | 84 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_run/arrowrun004.hs | 108 |
9 files changed, 337 insertions, 337 deletions
diff --git a/testsuite/tests/arrows/should_compile/arrowcase1.hs b/testsuite/tests/arrows/should_compile/arrowcase1.hs index 6d39b0be73..bc58315f50 100644 --- a/testsuite/tests/arrows/should_compile/arrowcase1.hs +++ b/testsuite/tests/arrows/should_compile/arrowcase1.hs @@ -6,13 +6,13 @@ import Control.Arrow h :: ArrowChoice a => Int -> a (Int,Int) Int h x = proc (y,z) -> case compare x y of - LT -> returnA -< x - EQ -> returnA -< y+z - GT -> returnA -< z+x + LT -> returnA -< x + EQ -> returnA -< y+z + GT -> returnA -< z+x g :: ArrowChoice a => Int -> a (Int,Int) Int g x = proc (y,z) -> (case compare x y of - LT -> \ a -> returnA -< x+a - EQ -> \ b -> returnA -< y+z+b - GT -> \ c -> returnA -< z+x + LT -> \ a -> returnA -< x+a + EQ -> \ b -> returnA -< y+z+b + GT -> \ c -> returnA -< z+x ) 1 diff --git a/testsuite/tests/arrows/should_compile/arrowdo1.hs b/testsuite/tests/arrows/should_compile/arrowdo1.hs index b70eedd460..ef54094af9 100644 --- a/testsuite/tests/arrows/should_compile/arrowdo1.hs +++ b/testsuite/tests/arrows/should_compile/arrowdo1.hs @@ -12,6 +12,6 @@ g x = proc y -> returnA -< x*y h :: Arrow a => Int -> a (Int,Int) Int h x = proc (y,z) -> do - a <- f -< (x,y,3) - b <- g (2+x) -< y+a - returnA -< a*b+z + a <- f -< (x,y,3) + b <- g (2+x) -< y+a + returnA -< a*b+z diff --git a/testsuite/tests/arrows/should_compile/arrowdo2.hs b/testsuite/tests/arrows/should_compile/arrowdo2.hs index 3562dc23b9..ca40f95a0a 100644 --- a/testsuite/tests/arrows/should_compile/arrowdo2.hs +++ b/testsuite/tests/arrows/should_compile/arrowdo2.hs @@ -6,5 +6,5 @@ import Control.Arrow f :: Arrow a => a (Int,Int) Int f = proc (x,y) -> do - let z = x*y - returnA -< y+z + let z = x*y + returnA -< y+z diff --git a/testsuite/tests/arrows/should_compile/arrowdo3.hs b/testsuite/tests/arrows/should_compile/arrowdo3.hs index 3b6a8c8d35..a46b06ef75 100644 --- a/testsuite/tests/arrows/should_compile/arrowdo3.hs +++ b/testsuite/tests/arrows/should_compile/arrowdo3.hs @@ -79,144 +79,144 @@ data T70 = C70 f :: Arrow a => a Int Int f = proc x0 -> do - x1 <- returnA -< C1 - x2 <- returnA -< C2 - x3 <- returnA -< C3 - x4 <- returnA -< C4 - x5 <- returnA -< C5 - x6 <- returnA -< C6 - x7 <- returnA -< C7 - x8 <- returnA -< C8 - x9 <- returnA -< C9 - x10 <- returnA -< C10 - x11 <- returnA -< C11 - x12 <- returnA -< C12 - x13 <- returnA -< C13 - x14 <- returnA -< C14 - x15 <- returnA -< C15 - x16 <- returnA -< C16 - x17 <- returnA -< C17 - x18 <- returnA -< C18 - x19 <- returnA -< C19 - x20 <- returnA -< C20 - x21 <- returnA -< C21 - x22 <- returnA -< C22 - x23 <- returnA -< C23 - x24 <- returnA -< C24 - x25 <- returnA -< C25 - x26 <- returnA -< C26 - x27 <- returnA -< C27 - x28 <- returnA -< C28 - x29 <- returnA -< C29 - x30 <- returnA -< C30 - x31 <- returnA -< C31 - x32 <- returnA -< C32 - x33 <- returnA -< C33 - x34 <- returnA -< C34 - x35 <- returnA -< C35 - x36 <- returnA -< C36 - x37 <- returnA -< C37 - x38 <- returnA -< C38 - x39 <- returnA -< C39 - x40 <- returnA -< C40 - x41 <- returnA -< C41 - x42 <- returnA -< C42 - x43 <- returnA -< C43 - x44 <- returnA -< C44 - x45 <- returnA -< C45 - x46 <- returnA -< C46 - x47 <- returnA -< C47 - x48 <- returnA -< C48 - x49 <- returnA -< C49 - x50 <- returnA -< C50 - x51 <- returnA -< C51 - x52 <- returnA -< C52 - x53 <- returnA -< C53 - x54 <- returnA -< C54 - x55 <- returnA -< C55 - x56 <- returnA -< C56 - x57 <- returnA -< C57 - x58 <- returnA -< C58 - x59 <- returnA -< C59 - x60 <- returnA -< C60 - x61 <- returnA -< C61 - x62 <- returnA -< C62 - x63 <- returnA -< C63 - x64 <- returnA -< C64 - x65 <- returnA -< C65 - x66 <- returnA -< C66 - x67 <- returnA -< C67 - x68 <- returnA -< C68 - x69 <- returnA -< C69 - x70 <- returnA -< C70 - returnA -< x70 - returnA -< x69 - returnA -< x68 - returnA -< x67 - returnA -< x66 - returnA -< x65 - returnA -< x64 - returnA -< x63 - returnA -< x62 - returnA -< x61 - returnA -< x60 - returnA -< x59 - returnA -< x58 - returnA -< x57 - returnA -< x56 - returnA -< x55 - returnA -< x54 - returnA -< x53 - returnA -< x52 - returnA -< x51 - returnA -< x50 - returnA -< x49 - returnA -< x48 - returnA -< x47 - returnA -< x46 - returnA -< x45 - returnA -< x44 - returnA -< x43 - returnA -< x42 - returnA -< x41 - returnA -< x40 - returnA -< x39 - returnA -< x38 - returnA -< x37 - returnA -< x36 - returnA -< x35 - returnA -< x34 - returnA -< x33 - returnA -< x32 - returnA -< x31 - returnA -< x30 - returnA -< x29 - returnA -< x28 - returnA -< x27 - returnA -< x26 - returnA -< x25 - returnA -< x24 - returnA -< x23 - returnA -< x22 - returnA -< x21 - returnA -< x20 - returnA -< x19 - returnA -< x18 - returnA -< x17 - returnA -< x16 - returnA -< x15 - returnA -< x14 - returnA -< x13 - returnA -< x12 - returnA -< x11 - returnA -< x10 - returnA -< x9 - returnA -< x8 - returnA -< x7 - returnA -< x6 - returnA -< x5 - returnA -< x4 - returnA -< x3 - returnA -< x2 - returnA -< x1 - returnA -< x0 + x1 <- returnA -< C1 + x2 <- returnA -< C2 + x3 <- returnA -< C3 + x4 <- returnA -< C4 + x5 <- returnA -< C5 + x6 <- returnA -< C6 + x7 <- returnA -< C7 + x8 <- returnA -< C8 + x9 <- returnA -< C9 + x10 <- returnA -< C10 + x11 <- returnA -< C11 + x12 <- returnA -< C12 + x13 <- returnA -< C13 + x14 <- returnA -< C14 + x15 <- returnA -< C15 + x16 <- returnA -< C16 + x17 <- returnA -< C17 + x18 <- returnA -< C18 + x19 <- returnA -< C19 + x20 <- returnA -< C20 + x21 <- returnA -< C21 + x22 <- returnA -< C22 + x23 <- returnA -< C23 + x24 <- returnA -< C24 + x25 <- returnA -< C25 + x26 <- returnA -< C26 + x27 <- returnA -< C27 + x28 <- returnA -< C28 + x29 <- returnA -< C29 + x30 <- returnA -< C30 + x31 <- returnA -< C31 + x32 <- returnA -< C32 + x33 <- returnA -< C33 + x34 <- returnA -< C34 + x35 <- returnA -< C35 + x36 <- returnA -< C36 + x37 <- returnA -< C37 + x38 <- returnA -< C38 + x39 <- returnA -< C39 + x40 <- returnA -< C40 + x41 <- returnA -< C41 + x42 <- returnA -< C42 + x43 <- returnA -< C43 + x44 <- returnA -< C44 + x45 <- returnA -< C45 + x46 <- returnA -< C46 + x47 <- returnA -< C47 + x48 <- returnA -< C48 + x49 <- returnA -< C49 + x50 <- returnA -< C50 + x51 <- returnA -< C51 + x52 <- returnA -< C52 + x53 <- returnA -< C53 + x54 <- returnA -< C54 + x55 <- returnA -< C55 + x56 <- returnA -< C56 + x57 <- returnA -< C57 + x58 <- returnA -< C58 + x59 <- returnA -< C59 + x60 <- returnA -< C60 + x61 <- returnA -< C61 + x62 <- returnA -< C62 + x63 <- returnA -< C63 + x64 <- returnA -< C64 + x65 <- returnA -< C65 + x66 <- returnA -< C66 + x67 <- returnA -< C67 + x68 <- returnA -< C68 + x69 <- returnA -< C69 + x70 <- returnA -< C70 + returnA -< x70 + returnA -< x69 + returnA -< x68 + returnA -< x67 + returnA -< x66 + returnA -< x65 + returnA -< x64 + returnA -< x63 + returnA -< x62 + returnA -< x61 + returnA -< x60 + returnA -< x59 + returnA -< x58 + returnA -< x57 + returnA -< x56 + returnA -< x55 + returnA -< x54 + returnA -< x53 + returnA -< x52 + returnA -< x51 + returnA -< x50 + returnA -< x49 + returnA -< x48 + returnA -< x47 + returnA -< x46 + returnA -< x45 + returnA -< x44 + returnA -< x43 + returnA -< x42 + returnA -< x41 + returnA -< x40 + returnA -< x39 + returnA -< x38 + returnA -< x37 + returnA -< x36 + returnA -< x35 + returnA -< x34 + returnA -< x33 + returnA -< x32 + returnA -< x31 + returnA -< x30 + returnA -< x29 + returnA -< x28 + returnA -< x27 + returnA -< x26 + returnA -< x25 + returnA -< x24 + returnA -< x23 + returnA -< x22 + returnA -< x21 + returnA -< x20 + returnA -< x19 + returnA -< x18 + returnA -< x17 + returnA -< x16 + returnA -< x15 + returnA -< x14 + returnA -< x13 + returnA -< x12 + returnA -< x11 + returnA -< x10 + returnA -< x9 + returnA -< x8 + returnA -< x7 + returnA -< x6 + returnA -< x5 + returnA -< x4 + returnA -< x3 + returnA -< x2 + returnA -< x1 + returnA -< x0 diff --git a/testsuite/tests/arrows/should_compile/arrowrec1.hs b/testsuite/tests/arrows/should_compile/arrowrec1.hs index 57b6de783c..b5a575ec66 100644 --- a/testsuite/tests/arrows/should_compile/arrowrec1.hs +++ b/testsuite/tests/arrows/should_compile/arrowrec1.hs @@ -7,7 +7,7 @@ import Data.Char f :: ArrowLoop a => a Char Int f = proc x -> do - a <- returnA -< ord x - rec b <- returnA -< ord c - ord x - c <- returnA -< chr a - returnA -< b + ord c + a <- returnA -< ord x + rec b <- returnA -< ord c - ord x + c <- returnA -< chr a + returnA -< b + ord c diff --git a/testsuite/tests/arrows/should_run/arrowrun001.hs b/testsuite/tests/arrows/should_run/arrowrun001.hs index c686b32546..90882b59a3 100644 --- a/testsuite/tests/arrows/should_run/arrowrun001.hs +++ b/testsuite/tests/arrows/should_run/arrowrun001.hs @@ -13,21 +13,21 @@ data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a) eval (Var s) = proc env -> - returnA -< fromJust (lookup s env) + returnA -< fromJust (lookup s env) eval (Add e1 e2) = proc env -> do - ~(Num u) <- eval e1 -< env - ~(Num v) <- eval e2 -< env - returnA -< Num (u + v) + ~(Num u) <- eval e1 -< env + ~(Num v) <- eval e2 -< env + returnA -< Num (u + v) eval (If e1 e2 e3) = proc env -> do - ~(Bl b) <- eval e1 -< env - if b then eval e2 -< env - else eval e3 -< env + ~(Bl b) <- eval e1 -< env + if b then eval e2 -< env + else eval e3 -< env eval (Lam x e) = proc env -> - returnA -< Fun (proc v -> eval e -< (x,v):env) + returnA -< Fun (proc v -> eval e -< (x,v):env) eval (App e1 e2) = proc env -> do - ~(Fun f) <- eval e1 -< env - v <- eval e2 -< env - f -<< v + ~(Fun f) <- eval e1 -< env + v <- eval e2 -< env + f -<< v -- some tests @@ -38,11 +38,11 @@ double = Lam "x" (Add (Var "x") (Var "x")) -- if b then k (double x) x else x + x + x text_exp = If (Var "b") - (App (App k (App double (Var "x"))) (Var "x")) - (Add (Var "x") (Add (Var "x") (Var "x"))) + (App (App k (App double (Var "x"))) (Var "x")) + (Add (Var "x") (Add (Var "x") (Var "x"))) unNum (Num n) = n main = do - print (unNum (eval text_exp [("b", Bl True), ("x", Num 5)])) - print (unNum (eval text_exp [("b", Bl False), ("x", Num 5)])) + print (unNum (eval text_exp [("b", Bl True), ("x", Num 5)])) + print (unNum (eval text_exp [("b", Bl False), ("x", Num 5)])) diff --git a/testsuite/tests/arrows/should_run/arrowrun002.hs b/testsuite/tests/arrows/should_run/arrowrun002.hs index 16f29806ac..2e606cf239 100644 --- a/testsuite/tests/arrows/should_run/arrowrun002.hs +++ b/testsuite/tests/arrows/should_run/arrowrun002.hs @@ -15,7 +15,7 @@ infixr 4 :&: -- or `powertrees' (cf Jayadev Misra's powerlists): data Pow a = Zero a | Succ (Pow (Pair a)) - deriving Show + deriving Show type Pair a = (a, a) @@ -33,7 +33,7 @@ tree3 = Succ (Succ (Succ (Zero (((1, 2), (3, 4)), ((5, 6), (7, 8)))))) -- in circuit design, eg Ruby, and descriptions of parallel algorithms.) -- And the type system will ensure that all legal programs preserve -- this structural invariant. --- +-- -- The only problem is that the type constraint is too restrictive, rejecting -- many of the standard operations on these trees. Typically you want to -- split a tree into two subtrees, do some processing on the subtrees and @@ -56,13 +56,13 @@ apply (f :&: fs) (Succ t) = Succ (apply fs t) -- programming with Hom's. Firstly, Hom is an arrow: instance Category Hom where - id = id :&: id - (f :&: fs) . (g :&: gs) = (f . g) :&: (fs . gs) + id = id :&: id + (f :&: fs) . (g :&: gs) = (f . g) :&: (fs . gs) instance Arrow Hom where - arr f = f :&: arr (f *** f) - first (f :&: fs) = - first f :&: (arr transpose >>> first fs >>> arr transpose) + arr f = f :&: arr (f *** f) + first (f :&: fs) = + first f :&: (arr transpose >>> first fs >>> arr transpose) transpose :: ((a,b), (c,d)) -> ((a,c), (b,d)) transpose ((a,b), (c,d)) = ((a,c), (b,d)) @@ -70,7 +70,7 @@ transpose ((a,b), (c,d)) = ((a,c), (b,d)) -- arr maps f over the leaves of a powertree. -- The composition >>> composes sequences of functions pairwise. --- +-- -- The *** operator unriffles a powertree of pairs into a pair of powertrees, -- applies the appropriate function to each and riffles the results. -- It defines a categorical product for this arrow category. @@ -85,9 +85,9 @@ transpose ((a,b), (c,d)) = ((a,c), (b,d)) butterfly :: (Pair a -> Pair a) -> Hom a a butterfly f = id :&: proc (x, y) -> do - x' <- butterfly f -< x - y' <- butterfly f -< y - returnA -< f (x', y') + x' <- butterfly f -< x + y' <- butterfly f -< y + returnA -< f (x', y') -- The recursive calls operate on halves of the original tree, so the -- recursion is well-defined. @@ -96,7 +96,7 @@ butterfly f = id :&: proc (x, y) -> do rev :: Hom a a rev = butterfly swap - where swap (x, y) = (y, x) + where swap (x, y) = (y, x) unriffle :: Hom (Pair a) (Pair a) unriffle = butterfly transpose @@ -105,26 +105,26 @@ unriffle = butterfly transpose bisort :: Ord a => Hom a a bisort = butterfly cmp - where cmp (x, y) = (min x y, max x y) + where cmp (x, y) = (min x y, max x y) -- This can be used (with rev) as the merge phase of a merge sort. --- +-- sort :: Ord a => Hom a a sort = id :&: proc (x, y) -> do - x' <- sort -< x - y' <- sort -< y - yr <- rev -< y' - p <- unriffle -< (x', yr) - bisort2 -< p - where _ :&: bisort2 = bisort + x' <- sort -< x + y' <- sort -< y + yr <- rev -< y' + p <- unriffle -< (x', yr) + bisort2 -< p + where _ :&: bisort2 = bisort -- Here is the scan operation, using the algorithm of Ladner and Fischer: scan :: (a -> a -> a) -> a -> Hom a a scan op b = id :&: proc (x, y) -> do - y' <- scan op b -< op x y - l <- rsh b -< y' - returnA -< (op l x, y') + y' <- scan op b -< op x y + l <- rsh b -< y' + returnA -< (op l x, y') -- The auxiliary function rsh b shifts each element in the tree one place to -- the right, placing b in the now-vacant leftmost position, and discarding @@ -132,8 +132,8 @@ scan op b = id :&: proc (x, y) -> do rsh :: a -> Hom a a rsh b = const b :&: proc (x, y) -> do - w <- rsh b -< y - returnA -< (w, x) + w <- rsh b -< y + returnA -< (w, x) -- Finally, here is the Fast Fourier Transform: @@ -141,11 +141,11 @@ type C = Complex Double fft :: Hom C C fft = id :&: proc (x, y) -> do - x' <- fft -< x - y' <- fft -< y - r <- roots (-1) -< () - let z = r*y' - unriffle -< (x' + z, x' - z) + x' <- fft -< x + y' <- fft -< y + r <- roots (-1) -< () + let z = r*y' + unriffle -< (x' + z, x' - z) -- The auxiliary function roots r (where r is typically a root of unity) -- populates a tree of size n (necessarily a power of 2) with the values @@ -153,73 +153,73 @@ fft = id :&: proc (x, y) -> do roots :: C -> Hom () C roots r = const 1 :&: proc _ -> do - x <- roots r' -< () - unriffle -< (x, x*r') - where r' = if imagPart s >= 0 then -s else s - s = sqrt r + x <- roots r' -< () + unriffle -< (x, x*r') + where r' = if imagPart s >= 0 then -s else s + s = sqrt r -- Miscellaneous functions: rrot :: Hom a a rrot = id :&: proc (x, y) -> do - w <- rrot -< y - returnA -< (w, x) + w <- rrot -< y + returnA -< (w, x) ilv :: Hom a a -> Hom (Pair a) (Pair a) ilv f = proc (x, y) -> do - x' <- f -< x - y' <- f -< y - returnA -< (x', y') + x' <- f -< x + y' <- f -< y + returnA -< (x', y') scan' :: (a -> a -> a) -> a -> Hom a a scan' op b = proc x -> do - l <- rsh b -< x - (id :&: ilv (scan' op b)) -< op l x + l <- rsh b -< x + (id :&: ilv (scan' op b)) -< op l x riffle :: Hom (Pair a) (Pair a) riffle = id :&: proc ((x1, y1), (x2, y2)) -> do - x <- riffle -< (x1, x2) - y <- riffle -< (y1, y2) - returnA -< (x, y) + x <- riffle -< (x1, x2) + y <- riffle -< (y1, y2) + returnA -< (x, y) invert :: Hom a a invert = id :&: proc (x, y) -> do - x' <- invert -< x - y' <- invert -< y - unriffle -< (x', y') + x' <- invert -< x + y' <- invert -< y + unriffle -< (x', y') carryLookaheadAdder :: Hom (Bool, Bool) Bool carryLookaheadAdder = proc (x, y) -> do - carryOut <- rsh (Just False) -< - if x == y then Just x else Nothing - Just carryIn <- scan plusMaybe Nothing -< carryOut - returnA -< x `xor` y `xor` carryIn - where plusMaybe x Nothing = x - plusMaybe x (Just y) = Just y - False `xor` b = b - True `xor` b = not b + carryOut <- rsh (Just False) -< + if x == y then Just x else Nothing + Just carryIn <- scan plusMaybe Nothing -< carryOut + returnA -< x `xor` y `xor` carryIn + where plusMaybe x Nothing = x + plusMaybe x (Just y) = Just y + False `xor` b = b + True `xor` b = not b -- Global conditional for SIMD ifAll :: Hom a b -> Hom a b -> Hom (a, Bool) b ifAll fs gs = ifAllAux snd (arr fst >>> fs) (arr fst >>> gs) - where ifAllAux :: (a -> Bool) -> Hom a b -> Hom a b -> Hom a b - ifAllAux p (f :&: fs) (g :&: gs) = - liftIf p f g :&: ifAllAux (liftAnd p) fs gs - liftIf p f g x = if p x then f x else g x - liftAnd p (x, y) = p x && p y + where ifAllAux :: (a -> Bool) -> Hom a b -> Hom a b -> Hom a b + ifAllAux p (f :&: fs) (g :&: gs) = + liftIf p f g :&: ifAllAux (liftAnd p) fs gs + liftIf p f g x = if p x then f x else g x + liftAnd p (x, y) = p x && p y maybeAll :: Hom a c -> Hom (a, b) c -> Hom (a, Maybe b) c maybeAll (n :&: ns) (j :&: js) = - choose :&: (arr dist >>> maybeAll ns (arr transpose >>> js)) - where choose (a, Nothing) = n a - choose (a, Just b) = j (a, b) - dist ((a1, b1), (a2, b2)) = ((a1, a2), zipMaybe b1 b2) - zipMaybe (Just x) (Just y) = Just (x, y) - zipMaybe _ _ = Nothing + choose :&: (arr dist >>> maybeAll ns (arr transpose >>> js)) + where choose (a, Nothing) = n a + choose (a, Just b) = j (a, b) + dist ((a1, b1), (a2, b2)) = ((a1, a2), zipMaybe b1 b2) + zipMaybe (Just x) (Just y) = Just (x, y) + zipMaybe _ _ = Nothing main = do - print (apply rev tree3) - print (apply invert tree3) - print (apply (invert >>> sort) tree3) - print (apply (scan (+) 0) tree3) + print (apply rev tree3) + print (apply invert tree3) + print (apply (invert >>> sort) tree3) + print (apply (scan (+) 0) tree3) diff --git a/testsuite/tests/arrows/should_run/arrowrun003.hs b/testsuite/tests/arrows/should_run/arrowrun003.hs index 5f4580ab87..eeab42556e 100644 --- a/testsuite/tests/arrows/should_run/arrowrun003.hs +++ b/testsuite/tests/arrows/should_run/arrowrun003.hs @@ -7,14 +7,14 @@ import Control.Category import Prelude hiding (id, (.)) class ArrowLoop a => ArrowCircuit a where - delay :: b -> a b b + delay :: b -> a b b -- stream map instance data Stream a = Cons a (Stream a) instance Functor Stream where - fmap f ~(Cons a as) = Cons (f a) (fmap f as) + fmap f ~(Cons a as) = Cons (f a) (fmap f as) zipStream :: Stream a -> Stream b -> Stream (a,b) zipStream ~(Cons a as) ~(Cons b bs) = Cons (a,b) (zipStream as bs) @@ -26,20 +26,20 @@ newtype StreamMap a b = StreamMap (Stream a -> Stream b) unStreamMap (StreamMap f) = f instance Category StreamMap where - id = StreamMap id - StreamMap f . StreamMap g = StreamMap (f . g) + id = StreamMap id + StreamMap f . StreamMap g = StreamMap (f . g) instance Arrow StreamMap where - arr f = StreamMap (fmap f) - first (StreamMap f) = - StreamMap (uncurry zipStream . first f . unzipStream) + arr f = StreamMap (fmap f) + first (StreamMap f) = + StreamMap (uncurry zipStream . first f . unzipStream) instance ArrowLoop StreamMap where - loop (StreamMap f) = - StreamMap (loop (unzipStream . f . uncurry zipStream)) + loop (StreamMap f) = + StreamMap (loop (unzipStream . f . uncurry zipStream)) instance ArrowCircuit StreamMap where - delay a = StreamMap (Cons a) + delay a = StreamMap (Cons a) listToStream :: [a] -> Stream a listToStream = foldr Cons undefined @@ -49,30 +49,30 @@ streamToList (Cons a as) = a:streamToList as runStreamMap :: StreamMap a b -> [a] -> [b] runStreamMap (StreamMap f) as = - take (length as) (streamToList (f (listToStream as))) + take (length as) (streamToList (f (listToStream as))) -- simple automaton instance data Auto a b = Auto (a -> (b, Auto a b)) instance Category Auto where - id = Auto $ \a -> (a, id) - Auto f . Auto g = Auto $ \b -> - let (c, g') = g b - (d, f') = f c - in (d, f' . g') + id = Auto $ \a -> (a, id) + Auto f . Auto g = Auto $ \b -> + let (c, g') = g b + (d, f') = f c + in (d, f' . g') instance Arrow Auto where - arr f = Auto $ \a -> (f a, arr f) - first (Auto f) = Auto $ \(b,d) -> let (c,f') = f b in ((c,d), first f') + arr f = Auto $ \a -> (f a, arr f) + first (Auto f) = Auto $ \(b,d) -> let (c,f') = f b in ((c,d), first f') instance ArrowLoop Auto where - loop (Auto f) = Auto $ \b -> - let (~(c,d), f') = f (b,d) - in (c, loop f') + loop (Auto f) = Auto $ \b -> + let (~(c,d), f') = f (b,d) + in (c, loop f') instance ArrowCircuit Auto where - delay a = Auto $ \a' -> (a, delay a') + delay a = Auto $ \a' -> (a, delay a') runAuto :: Auto a b -> [a] -> [b] runAuto (Auto f) [] = [] @@ -84,9 +84,9 @@ runAuto (Auto f) (a:as) = let (b, f') = f a in b:runAuto f' as counter :: ArrowCircuit a => a Bool Int counter = proc reset -> do - rec output <- returnA -< if reset then 0 else next - next <- delay 0 -< output+1 - returnA -< output + rec output <- returnA -< if reset then 0 else next + next <- delay 0 -< output+1 + returnA -< output -- Some other basic circuits from the Hawk library. @@ -95,18 +95,18 @@ counter = proc reset -> do flush :: ArrowCircuit a => Int -> b -> a (b, Bool) b flush n d = proc (value, reset) -> do - rec count <- returnA -< if reset then n else max (next-1) 0 - next <- delay 0 -< count - returnA -< if count > 0 then d else value + rec count <- returnA -< if reset then n else max (next-1) 0 + next <- delay 0 -< count + returnA -< if count > 0 then d else value -- latch: on each tick, return the last value for which reset was True, -- or init if there was none. --- +-- latch :: ArrowCircuit a => b -> a (b, Bool) b latch init = proc (value, reset) -> do - rec out <- returnA -< if reset then value else last - last <- delay init -< out - returnA -< out + rec out <- returnA -< if reset then value else last + last <- delay init -< out + returnA -< out -- Some tests using the counter @@ -116,18 +116,18 @@ test_input2 = zip [1..] test_input -- A test of the resettable counter. main = do - print (runStreamMap counter test_input) - print (runAuto counter test_input) - print (runStreamMap (flush 2 0) test_input2) - print (runAuto (flush 2 0) test_input2) - print (runStreamMap (latch 0) test_input2) - print (runAuto (latch 0) test_input2) + print (runStreamMap counter test_input) + print (runAuto counter test_input) + print (runStreamMap (flush 2 0) test_input2) + print (runAuto (flush 2 0) test_input2) + print (runStreamMap (latch 0) test_input2) + print (runAuto (latch 0) test_input2) -- A step function (cf current in Lustre) step :: ArrowCircuit a => b -> a (Either b c) b step b = proc x -> do - rec last_b <- delay b -< getLeft last_b x - returnA -< last_b - where getLeft _ (Left b) = b - getLeft b (Right _) = b + rec last_b <- delay b -< getLeft last_b x + returnA -< last_b + where getLeft _ (Left b) = b + getLeft b (Right _) = b diff --git a/testsuite/tests/arrows/should_run/arrowrun004.hs b/testsuite/tests/arrows/should_run/arrowrun004.hs index c0275065f2..1b22ac83b4 100644 --- a/testsuite/tests/arrows/should_run/arrowrun004.hs +++ b/testsuite/tests/arrows/should_run/arrowrun004.hs @@ -13,7 +13,7 @@ import Prelude hiding (id, (.)) -- Parsers class (Eq s, Show s, ArrowPlus a) => ArrowParser s a where - symbol :: s -> a b String + symbol :: s -> a b String data Sym s = Sym { token :: s, value :: String } @@ -22,35 +22,35 @@ data Sym s = Sym { token :: s, value :: String } newtype BTParser s a b = BTParser (a -> [Sym s] -> [(b, [Sym s])]) instance Category (BTParser s) where - id = BTParser $ \a ss -> [(a, ss)] - BTParser f . BTParser g = BTParser $ \b ss -> - [(d, ss'') | (c, ss') <- g b ss, (d, ss'') <- f c ss'] + id = BTParser $ \a ss -> [(a, ss)] + BTParser f . BTParser g = BTParser $ \b ss -> + [(d, ss'') | (c, ss') <- g b ss, (d, ss'') <- f c ss'] instance Arrow (BTParser s) where - arr f = BTParser $ \a ss -> [(f a, ss)] - first (BTParser f) = BTParser $ \(b,d) ss -> - [((c,d), ss') | (c,ss') <- f b ss] + arr f = BTParser $ \a ss -> [(f a, ss)] + first (BTParser f) = BTParser $ \(b,d) ss -> + [((c,d), ss') | (c,ss') <- f b ss] instance ArrowZero (BTParser s) where - zeroArrow = BTParser $ \b ss -> [] + zeroArrow = BTParser $ \b ss -> [] instance ArrowPlus (BTParser s) where - BTParser f <+> BTParser g = BTParser $ \b ss -> f b ss ++ g b ss + BTParser f <+> BTParser g = BTParser $ \b ss -> f b ss ++ g b ss instance (Eq s, Show s) => ArrowParser s (BTParser s) where - symbol s = BTParser $ \b ss -> - case ss of - Sym s' v:ss' | s' == s -> [(v, ss')] - _ -> [] + symbol s = BTParser $ \b ss -> + case ss of + Sym s' v:ss' | s' == s -> [(v, ss')] + _ -> [] runBTParser :: BTParser s () c -> [Sym s] -> c runBTParser (BTParser parser) syms = - head [c | (c, []) <- parser () syms] + head [c | (c, []) <- parser () syms] -- Expressions data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord) type ExprParser = BTParser ESym type ExprSym = Sym ESym @@ -59,51 +59,51 @@ type ExprSym = Sym ESym expr :: ExprParser () Int expr = proc () -> do - x <- term -< () - expr' -< x + x <- term -< () + expr' -< x expr' :: ExprParser Int Int expr' = proc x -> do - returnA -< x - <+> do - (|(symbol Plus)|) - y <- term -< () - expr' -< x + y - <+> do - (|(symbol Minus)|) - y <- term -< () - expr' -< x - y + returnA -< x + <+> do + (|(symbol Plus)|) + y <- term -< () + expr' -< x + y + <+> do + (|(symbol Minus)|) + y <- term -< () + expr' -< x - y term :: ExprParser () Int term = proc () -> do - x <- factor -< () - term' -< x + x <- factor -< () + term' -< x term' :: ExprParser Int Int term' = proc x -> do - returnA -< x - <+> do - (|(symbol Mult)|) - y <- factor -< () - term' -< x * y - <+> do - (|(symbol Div)|) - y <- factor -< () - term' -< x `div` y + returnA -< x + <+> do + (|(symbol Mult)|) + y <- factor -< () + term' -< x * y + <+> do + (|(symbol Div)|) + y <- factor -< () + term' -< x `div` y factor :: ExprParser () Int factor = proc () -> do - v <- (|(symbol Number)|) - returnA -< read v::Int - <+> do - (|(symbol Minus)|) - v <- factor -< () - returnA -< -v - <+> do - (|(symbol LPar)|) - v <- expr -< () - (|(symbol RPar)|) - returnA -< v + v <- (|(symbol Number)|) + returnA -< read v::Int + <+> do + (|(symbol Minus)|) + v <- factor -< () + returnA -< -v + <+> do + (|(symbol LPar)|) + v <- expr -< () + (|(symbol RPar)|) + returnA -< v -- Lexical analysis @@ -116,13 +116,13 @@ lexer ('-':cs) = Sym Minus "-":lexer cs lexer ('*':cs) = Sym Mult "*":lexer cs lexer ('/':cs) = Sym Div "/":lexer cs lexer (c:cs) - | isSpace c = lexer cs - | isDigit c = Sym Number (c:w):lexer cs' - | otherwise = Sym Unknown [c]:lexer cs - where (w,cs') = span isDigit cs + | isSpace c = lexer cs + | isDigit c = Sym Number (c:w):lexer cs' + | otherwise = Sym Unknown [c]:lexer cs + where (w,cs') = span isDigit cs parse = runBTParser expr . lexer main = do - print (parse "1+2*(3+4)") - print (parse "3*5-17/3+4") + print (parse "1+2*(3+4)") + print (parse "3*5-17/3+4") |