diff options
Diffstat (limited to 'testsuite/tests/arrows/should_compile')
18 files changed, 460 insertions, 0 deletions
diff --git a/testsuite/tests/arrows/should_compile/Makefile b/testsuite/tests/arrows/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/arrows/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/arrows/should_compile/T3964.hs b/testsuite/tests/arrows/should_compile/T3964.hs new file mode 100644 index 0000000000..713c7e2303 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/T3964.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Arrows, ViewPatterns #-} + +module T3964 where + +import Control.Arrow + +testF :: Eq a => a -> (Maybe (Maybe a)) -> Maybe a +testF v = proc x -> case x of + Just (Just ((==v) -> True)) -> returnA -< Just v + _ -> returnA -< Nothing diff --git a/testsuite/tests/arrows/should_compile/T5283.hs b/testsuite/tests/arrows/should_compile/T5283.hs new file mode 100644 index 0000000000..9216d3cd67 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/T5283.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE Arrows #-} +-- Failed in ghci + +module T where + +import Prelude +import Control.Arrow + +mapAC :: Arrow arr => Integer -> arr (env, b) c -> arr (env, [b]) [c] +mapAC n farr = go 1 + where + go i | i == succ n = arr (\(_env, []) -> []) + | otherwise = proc ~(env, b : bs) -> + do c <- farr -< (env, b) + cs <- go (succ i) -< (env, bs) + returnA -< c : cs + +t :: Arrow arr => arr [a] [a] +t = proc ys -> + (| (mapAC 3) (\y -> returnA -< y) |) ys diff --git a/testsuite/tests/arrows/should_compile/all.T b/testsuite/tests/arrows/should_compile/all.T new file mode 100644 index 0000000000..3351b9f4ba --- /dev/null +++ b/testsuite/tests/arrows/should_compile/all.T @@ -0,0 +1,18 @@ +setTestOpts(only_compiler_types(['ghc'])) + +test('arrowapply1', normal, compile, ['']) +test('arrowapply2', normal, compile, ['']) +test('arrowapply3', normal, compile, ['']) +test('arrowapply4', normal, compile, ['']) +test('arrowapply5', normal, compile, ['']) +test('arrowcase1', normal, compile, ['']) +test('arrowdo1', normal, compile, ['']) +test('arrowdo2', normal, compile, ['']) +# test('arrowdo3', normal, compile, ['']) # takes too long +test('arrowform1', normal, compile, ['']) +test('arrowif1', normal, compile, ['']) +test('arrowlet1', normal, compile, ['']) +test('arrowrec1', normal, compile, ['']) +test('arrowpat', normal, compile, ['']) +test('T3964', normal, compile, ['']) +test('T5283', normal, compile, ['']) diff --git a/testsuite/tests/arrows/should_compile/arrowapply1.hs b/testsuite/tests/arrows/should_compile/arrowapply1.hs new file mode 100644 index 0000000000..abad47de26 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowapply1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow + +f :: Arrow a => a (Int,Int,Int) Int +f = proc (x,y,z) -> returnA -< x+y diff --git a/testsuite/tests/arrows/should_compile/arrowapply2.hs b/testsuite/tests/arrows/should_compile/arrowapply2.hs new file mode 100644 index 0000000000..16cf2f3039 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowapply2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow + +f :: ArrowApply a => a (a Int Int,Int,Int) Int +f = proc (x,y,z) -> x -<< 2+y + +g :: ArrowApply a => Int -> a (a Int Int,Int) Int +g y = proc (x,z) -> x -<< 2+y diff --git a/testsuite/tests/arrows/should_compile/arrowapply3.hs b/testsuite/tests/arrows/should_compile/arrowapply3.hs new file mode 100644 index 0000000000..3a9b49da92 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowapply3.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow + +g :: Arrow a => a Int c -> a Int c +g f = proc b -> f -< b+2 diff --git a/testsuite/tests/arrows/should_compile/arrowapply4.hs b/testsuite/tests/arrows/should_compile/arrowapply4.hs new file mode 100644 index 0000000000..af0dac4cee --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowapply4.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +-- example from Sebastian Boldt <Sebastian.Boldt@arcor.de>: +-- (f -< a) b === f -< (a,b) + +import Control.Arrow + +mshowA :: (Arrow a, Show b) => a (b, String) String +mshowA = proc (x,s) -> returnA -< s ++ show x ++ s + +f :: Arrow a => a Int String +f = proc x -> (mshowA -< x) "***" + +g :: ArrowApply a => a Int String +g = proc x -> (mshowA -<< x) "***" diff --git a/testsuite/tests/arrows/should_compile/arrowapply5.hs b/testsuite/tests/arrows/should_compile/arrowapply5.hs new file mode 100644 index 0000000000..46d1dc587f --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowapply5.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +-- variables bound inside the left argument of -< should be in scope + +import Control.Arrow + +f :: (Num b, Arrow a) => a b b +f = proc x -> arr (\y -> y-1) -< x + +g :: (Num b, Arrow a) => a b b +g = proc x -> (proc y -> returnA -< y-1) -< x diff --git a/testsuite/tests/arrows/should_compile/arrowcase1.hs b/testsuite/tests/arrows/should_compile/arrowcase1.hs new file mode 100644 index 0000000000..6d39b0be73 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowcase1.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +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 + +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 + ) 1 diff --git a/testsuite/tests/arrows/should_compile/arrowdo1.hs b/testsuite/tests/arrows/should_compile/arrowdo1.hs new file mode 100644 index 0000000000..b70eedd460 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowdo1.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow + +f :: Arrow a => a (Int,Int,Int) Int +f = proc (x,y,z) -> returnA -< x+y + +g :: Arrow a => Int -> a Int Int +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 diff --git a/testsuite/tests/arrows/should_compile/arrowdo2.hs b/testsuite/tests/arrows/should_compile/arrowdo2.hs new file mode 100644 index 0000000000..3562dc23b9 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowdo2.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow + +f :: Arrow a => a (Int,Int) Int +f = proc (x,y) -> do + 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 new file mode 100644 index 0000000000..3b6a8c8d35 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowdo3.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE Arrows #-} + +-- test for out-size tuples: takes a _long_ time to compile + +module ShouldCompile where + +import Control.Arrow + +data T1 = C1 +data T2 = C2 +data T3 = C3 +data T4 = C4 +data T5 = C5 +data T6 = C6 +data T7 = C7 +data T8 = C8 +data T9 = C9 +data T10 = C10 +data T11 = C11 +data T12 = C12 +data T13 = C13 +data T14 = C14 +data T15 = C15 +data T16 = C16 +data T17 = C17 +data T18 = C18 +data T19 = C19 +data T20 = C20 +data T21 = C21 +data T22 = C22 +data T23 = C23 +data T24 = C24 +data T25 = C25 +data T26 = C26 +data T27 = C27 +data T28 = C28 +data T29 = C29 +data T30 = C30 +data T31 = C31 +data T32 = C32 +data T33 = C33 +data T34 = C34 +data T35 = C35 +data T36 = C36 +data T37 = C37 +data T38 = C38 +data T39 = C39 +data T40 = C40 +data T41 = C41 +data T42 = C42 +data T43 = C43 +data T44 = C44 +data T45 = C45 +data T46 = C46 +data T47 = C47 +data T48 = C48 +data T49 = C49 +data T50 = C50 +data T51 = C51 +data T52 = C52 +data T53 = C53 +data T54 = C54 +data T55 = C55 +data T56 = C56 +data T57 = C57 +data T58 = C58 +data T59 = C59 +data T60 = C60 +data T61 = C61 +data T62 = C62 +data T63 = C63 +data T64 = C64 +data T65 = C65 +data T66 = C66 +data T67 = C67 +data T68 = C68 +data T69 = C69 +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 diff --git a/testsuite/tests/arrows/should_compile/arrowform1.hs b/testsuite/tests/arrows/should_compile/arrowform1.hs new file mode 100644 index 0000000000..a282d71ed7 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowform1.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow + +handle :: ArrowPlus a => a b c -> a (b,String) c -> a b c +handle f h = proc b -> (f -< b) <+> (h -< (b,"")) + +f :: ArrowPlus a => a (Int,Int) String +f = proc (x,y) -> + (|handle + (returnA -< show y) + (\s -> returnA -< s ++ show x) + |) + +g :: ArrowPlus a => a (Int,Int) String +g = proc (x,y) -> + (|handle + (\msg -> returnA -< msg ++ show y) + (\s msg -> returnA -< s ++ show x) + |) ("hello " ++ show x) + +h :: ArrowPlus a => a (Int,Int) Int +h = proc (x,y) -> + ( + (\z -> returnA -< x + z) + <+> + (\z -> returnA -< y + z) + ) (x*y) diff --git a/testsuite/tests/arrows/should_compile/arrowif1.hs b/testsuite/tests/arrows/should_compile/arrowif1.hs new file mode 100644 index 0000000000..404b1f164c --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowif1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow + +f :: ArrowChoice a => a (Int,Int,Int) Int +f = proc (x,y,z) -> if x < y then returnA -< x+y else returnA -< x+z + +g :: ArrowChoice a => Int -> a (Int,Int) Int +g x = proc (y,z) -> if x < y then returnA -< x+y else returnA -< x+z diff --git a/testsuite/tests/arrows/should_compile/arrowlet1.hs b/testsuite/tests/arrows/should_compile/arrowlet1.hs new file mode 100644 index 0000000000..b08e030d1c --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowlet1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow + +f :: Arrow a => a (Int,Int) Int +f = proc (x,y) -> let z = x*y in returnA -< y+z diff --git a/testsuite/tests/arrows/should_compile/arrowpat.hs b/testsuite/tests/arrows/should_compile/arrowpat.hs new file mode 100644 index 0000000000..56b1117e9a --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowpat.hs @@ -0,0 +1,23 @@ +{-# OPTIONS -XArrows #-} + +-- Test for Trac #1662 + +module Arrow where + +import Control.Arrow + +expr' :: Arrow a => a Int Int +expr' = error "urk" + +term :: Arrow a => a () Int +term = error "urk" + +expr1 :: Arrow a => a () Int +expr1 = proc () -> do + x <- term -< () + expr' -< x + +expr2 :: Arrow a => a () Int +expr2 = proc y -> do + x <- term -< y + expr' -< x diff --git a/testsuite/tests/arrows/should_compile/arrowrec1.hs b/testsuite/tests/arrows/should_compile/arrowrec1.hs new file mode 100644 index 0000000000..57b6de783c --- /dev/null +++ b/testsuite/tests/arrows/should_compile/arrowrec1.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Arrows #-} + +module ShouldCompile where + +import Control.Arrow +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 |