diff options
Diffstat (limited to 'testsuite/tests/stranal/should_compile')
30 files changed, 370 insertions, 0 deletions
diff --git a/testsuite/tests/stranal/should_compile/Makefile b/testsuite/tests/stranal/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/stranal/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/stranal/should_compile/T1988.hs b/testsuite/tests/stranal/should_compile/T1988.hs new file mode 100644 index 0000000000..da99806ce1 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T1988.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -O2 #-} + +-- Trac #1988: this one killed GHC 6.8.2 +-- at least with -O2 + +module ShouldCompile where + +newtype CFTree = CFTree (String, [CFTree]) + +prCFTree :: CFTree -> String +prCFTree (CFTree (_,trees)) = concatMap ps trees + where ps t@(CFTree (_,[])) = prCFTree t diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T new file mode 100644 index 0000000000..5814f39f7d --- /dev/null +++ b/testsuite/tests/stranal/should_compile/all.T @@ -0,0 +1,18 @@ +# Only compile with optimisation +setTestOpts( only_ways(['optasm']) ) + +test('default', normal, compile, ['']) +test('fact', normal, compile, ['']) +test('fun', normal, compile, ['']) +test('goo', normal, compile, ['']) +test('ins', normal, compile, ['']) +test('map', normal, compile, ['']) +test('sim', normal, compile, ['']) +test('str001', normal, compile, ['']) +test('str002', normal, compile, ['']) +test('syn', normal, compile, ['']) +test('test', normal, compile, ['']) +test('tst', normal, compile, ['']) +test('unu', normal, compile, ['']) +test('newtype', req_profiling, compile, ['-prof -auto-all']) +test('T1988', normal, compile, ['']) diff --git a/testsuite/tests/stranal/should_compile/default.hs b/testsuite/tests/stranal/should_compile/default.hs new file mode 100644 index 0000000000..43eb9f0633 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/default.hs @@ -0,0 +1,16 @@ +module Test where +data Boolean = FF | TT +data Pair a b = MkPair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree x = Leaf x | Node (Tree x) (Tree x) +data A a = MkA a (A a) + +append :: LList a -> LList a -> LList a +append xs ys = case xs of + Conss z zs -> Conss z (append zs ys) + v -> ys + + + + diff --git a/testsuite/tests/stranal/should_compile/default.stderr b/testsuite/tests/stranal/should_compile/default.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/default.stderr diff --git a/testsuite/tests/stranal/should_compile/fact.hs b/testsuite/tests/stranal/should_compile/fact.hs new file mode 100644 index 0000000000..9f23f9021e --- /dev/null +++ b/testsuite/tests/stranal/should_compile/fact.hs @@ -0,0 +1,3 @@ +module Test where +fact :: Int -> Int +fact n = if n==0 then 2 else (fact n) * n diff --git a/testsuite/tests/stranal/should_compile/fact.stderr b/testsuite/tests/stranal/should_compile/fact.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/fact.stderr diff --git a/testsuite/tests/stranal/should_compile/fun.hs b/testsuite/tests/stranal/should_compile/fun.hs new file mode 100644 index 0000000000..5bab460f3f --- /dev/null +++ b/testsuite/tests/stranal/should_compile/fun.hs @@ -0,0 +1,6 @@ +module Test where +data Fun = MkFun (Fun -> Fun) +data LList a = Nill | Conss a (LList a) + +g :: Fun -> Fun +g f = f diff --git a/testsuite/tests/stranal/should_compile/fun.stderr b/testsuite/tests/stranal/should_compile/fun.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/fun.stderr diff --git a/testsuite/tests/stranal/should_compile/goo.hs b/testsuite/tests/stranal/should_compile/goo.hs new file mode 100644 index 0000000000..00282bb79e --- /dev/null +++ b/testsuite/tests/stranal/should_compile/goo.hs @@ -0,0 +1,10 @@ +module Test where +data Goo a = Gsimpl | Gcompl ([Goo a]) +data Moo a b = Msimple | Mcompl (Moo b a) + + +idGoo :: Goo a -> Goo a +idGoo x = x + +idMoo :: Moo a b -> Moo a b +idMoo x = x diff --git a/testsuite/tests/stranal/should_compile/goo.stderr b/testsuite/tests/stranal/should_compile/goo.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/goo.stderr diff --git a/testsuite/tests/stranal/should_compile/ins.hs b/testsuite/tests/stranal/should_compile/ins.hs new file mode 100644 index 0000000000..a50320cefa --- /dev/null +++ b/testsuite/tests/stranal/should_compile/ins.hs @@ -0,0 +1,27 @@ +-- !! TEST OF DEFACTORISATION FOR FUNCTIONS THAT DROP +-- !! POLYMORPHIC VARIABLES + +module Test where +data Boolean = FF | TT +data Pair a b = MkPair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree x = Leaf x | Node (Tree x) (Tree x) +data A a = MkA a (A a) + +append :: LList a -> LList a -> LList a +append xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (append zs ys) + +-- The following function drops @b@. + +flat :: Tree (Pair a b) -> LList a +flat t = case t of + Leaf (MkPair a b) -> Conss a Nill + Node l r -> append (flat l) (flat r) + +fl :: Boolean -> LList Boolean +fl x = flat (Leaf (MkPair TT Zero)) + + diff --git a/testsuite/tests/stranal/should_compile/ins.stderr b/testsuite/tests/stranal/should_compile/ins.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/ins.stderr diff --git a/testsuite/tests/stranal/should_compile/map.hs b/testsuite/tests/stranal/should_compile/map.hs new file mode 100644 index 0000000000..f4ec1ec769 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/map.hs @@ -0,0 +1,32 @@ +module Test where +data Boolean = FF | TT +data Pair a b = MkPair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree x = Leaf x | Node (Tree x) (Tree x) +data A a = MkA a (A a) + +{- +map :: (a -> b) -> [a] -> [b] +map f xs = case xs of + [] -> [] + (y:ys) -> (f y):(map f ys) + +map_ide :: [[a]] -> [[a]] +map_ide = map (\x->x) +-} + +my_id :: a -> a +my_id x = x + +idNat :: Nat -> Nat +idNat x = x + +idBool :: Boolean -> Boolean +idBool x = x + +fun :: (a->b) -> a -> b +fun f x = g f + where + g f = f x + diff --git a/testsuite/tests/stranal/should_compile/map.stderr b/testsuite/tests/stranal/should_compile/map.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/map.stderr diff --git a/testsuite/tests/stranal/should_compile/newtype.hs b/testsuite/tests/stranal/should_compile/newtype.hs new file mode 100644 index 0000000000..c68df28111 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/newtype.hs @@ -0,0 +1,14 @@ +-- This one killed GHC 6.4 because it bogusly attributed +-- the CPR property to the construtor T +-- Result: a mkWWcpr crash +-- Needs -prof -auto-all to show it up + +module ShouldCompile where + +newtype T a = T { unT :: a } + +f = unT + +test cs = f $ case cs of + [] -> T [] + (x:xs) -> T $ test cs diff --git a/testsuite/tests/stranal/should_compile/sim.hs b/testsuite/tests/stranal/should_compile/sim.hs new file mode 100644 index 0000000000..d6de6ec09d --- /dev/null +++ b/testsuite/tests/stranal/should_compile/sim.hs @@ -0,0 +1,103 @@ +module Test where +data Boolean = FF | TT +data Pair a b = MkPair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree x = Leaf x | Node (Tree x) (Tree x) +data A a = MkA a (A a) +{- +id :: a -> a +id x = x + +idb :: Boolean -> Boolean +idb b = b + +swap :: Pair a b -> Pair b a +swap t = case t of + MkPair x y -> MkPair y x + +bang :: A (A a) -> Boolean +bang x = case x of + MkA y ys -> TT + +neg :: Boolean -> Boolean +neg b = case b of + FF -> TT + TT -> FF + +null :: LList x -> Boolean +null l = case l of + Nill -> TT + _ -> FF + +loop :: Boolean -> a +loop b = loop b +-} +idl :: LList a -> LList a +idl xs = case xs of + Conss y ys -> Conss y (idl ys) + _ -> Nill +{- +idn :: Nat -> Nat +idn n = case n of + Zero -> Zero + Succ m -> Succ (idn m) + +add :: Nat -> Nat -> Nat +add a b = case a of + Zero -> b + Succ c -> Succ (add c b) + +length :: LList a -> Nat +length xs = case xs of + Nill -> Zero + Conss y ys -> Succ(length ys) + +before :: LList Nat -> LList Nat +before xs = case xs of + Nill -> Nill + Conss y ys -> case y of + Zero -> Nill + Succ n -> Conss y (before ys) + +reverse :: LList a -> LList a +reverse rs = case rs of + Nill -> Nill + Conss y ys -> append (reverse ys) (Conss y Nill) + +f :: Nat -> Nat +f n = case n of + Zero -> Zero + Succ m -> Succ (g m) + +g :: Nat -> Nat +g n = case n of + Zero -> Zero + Succ m -> Succ (f m) + +append :: LList a -> LList a -> LList a +append xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (append zs ys) + +flatten :: Tree alpha -> LList alpha +flatten t = case t of + Leaf x -> Conss x Nill + Node l r -> append (flatten l) (flatten r) + +sum :: Tree Nat -> Nat +sum t = case t of + Leaf t -> t + Node l r -> add (sum l) (sum r) + +suml :: LList Nat -> Nat +suml Nill = Zero +suml (Conss n ns) = add n (suml ns) + +map :: (a -> b) -> LList a -> LList b +map f xs = case xs of + Nill -> Nill + Conss y ys -> Conss (f y) (map f ys) +-} + + diff --git a/testsuite/tests/stranal/should_compile/sim.stderr b/testsuite/tests/stranal/should_compile/sim.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/sim.stderr diff --git a/testsuite/tests/stranal/should_compile/str001.hs b/testsuite/tests/stranal/should_compile/str001.hs new file mode 100644 index 0000000000..6d27a923fd --- /dev/null +++ b/testsuite/tests/stranal/should_compile/str001.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DatatypeContexts #-} +module ShouldSucceed where + +{-# OPTIONS -O #-} + +newtype Num a => Point2 a = Point2 (a,a) + +area2 :: Num a => Point2 a -> Point2 a -> Point2 a -> a +area2 (Point2 (px,py)) (Point2 (qx,qy)) (Point2 (rx,ry)) + = (px-qx) * (py-ry) - (py-qy) * (px-rx) diff --git a/testsuite/tests/stranal/should_compile/str001.stderr b/testsuite/tests/stranal/should_compile/str001.stderr new file mode 100644 index 0000000000..968ccf8885 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/str001.stderr @@ -0,0 +1,4 @@ + +str001.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + diff --git a/testsuite/tests/stranal/should_compile/str002.hs b/testsuite/tests/stranal/should_compile/str002.hs new file mode 100644 index 0000000000..65fb8a7ba2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/str002.hs @@ -0,0 +1,12 @@ +-- !!! Recursive newtypes +-- Needs -O +-- This one made GHC < 5.00.2 go into an +-- infinite loop in the strictness analysier + +module Foo where + +newtype V = MkV V + +f :: V -> V +f (MkV v) = v + diff --git a/testsuite/tests/stranal/should_compile/str002.stderr b/testsuite/tests/stranal/should_compile/str002.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/str002.stderr diff --git a/testsuite/tests/stranal/should_compile/syn.hs b/testsuite/tests/stranal/should_compile/syn.hs new file mode 100644 index 0000000000..6693db70d9 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/syn.hs @@ -0,0 +1,15 @@ +-- !!! THIS TEST IS FOR TYPE SYNONIMS AND FACTORISATION IN THEIR PRESENCE. + +module Test where +data M a = A | B a (M a) +data L a = N | C a (Syn a) +type Syn b = L b + +idL :: L (Syn c) -> L (Syn c) +idL N = N +idL (C x l) = C x (idL l) + +idM:: M (L (Syn x)) -> M (L (Syn x)) +idM A = A +idM (B x l) = B (idL x) (idM l) + diff --git a/testsuite/tests/stranal/should_compile/syn.stderr b/testsuite/tests/stranal/should_compile/syn.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/syn.stderr diff --git a/testsuite/tests/stranal/should_compile/test.hs b/testsuite/tests/stranal/should_compile/test.hs new file mode 100644 index 0000000000..c984c320d1 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/test.hs @@ -0,0 +1,6 @@ +module Test where +data LList t = Nill | Conss t (LList t) +data BBool = TTrue | FFalse + +f Nill = TTrue +f (Conss a as) = FFalse diff --git a/testsuite/tests/stranal/should_compile/test.stderr b/testsuite/tests/stranal/should_compile/test.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/test.stderr diff --git a/testsuite/tests/stranal/should_compile/tst.hs b/testsuite/tests/stranal/should_compile/tst.hs new file mode 100644 index 0000000000..561292107b --- /dev/null +++ b/testsuite/tests/stranal/should_compile/tst.hs @@ -0,0 +1,3 @@ +module Test where +a :: [a] -> [[a]] +a x = [x] diff --git a/testsuite/tests/stranal/should_compile/tst.stderr b/testsuite/tests/stranal/should_compile/tst.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/tst.stderr diff --git a/testsuite/tests/stranal/should_compile/unu.hs b/testsuite/tests/stranal/should_compile/unu.hs new file mode 100644 index 0000000000..54bb25e9ab --- /dev/null +++ b/testsuite/tests/stranal/should_compile/unu.hs @@ -0,0 +1,76 @@ +module Test where +data Boolean = FF | TT +data Pair a b = Mkpair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree t = Leaf t | Node (Tree t) (Tree t) +data A a = MkA a (A a) +data Foo baz = MkFoo (Foo (Foo baz)) +{- + append1 :: LList a -> LList a -> LList a + append1 xs ys = append2 xs + where + append2 xs = case xs of + Nill -> ys + Conss x xs -> Conss x (append3 xs) + append3 xs = case xs of + Nill -> ys + Conss x xs -> Conss x (append2 xs) + + loop :: a -> a + loop x = loop x + + hd :: LList b -> b + hd Nill = loop + hd (Conss y ys) = y + + hdb :: LList (LList b) -> LList b + hdb = hd + + append :: [a] -> [a] -> [a] + append [] ys = ys + append (x:xs) ys = x:(append xs ys) + + f :: [a] -> [a] + f y = append x (f y) + where x = append x (f y) +-} +app :: LList a -> LList a -> LList a +app Nill Nill = Nill +app xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (app zs ys) +{- + app :: LList a -> LList a -> LList a + app xs ys = case xs of + Nill -> case ys of + Nill -> Nill + Conss u us -> ap + Conss a as -> ap + where ap = case xs of + Nill -> ys + Conss z zs -> Conss z (app zs ys) + + app :: LList a -> LList a -> LList a + app xs ys = case xs of + Nill -> case ys of + Nill -> Nill + Conss u us -> ap xs ys + Conss a as -> ap xs ys + + ap xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (app zs ys) + + ap :: LList a -> LList a -> LList a + ap xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (ap zs ys) + + app :: LList a -> LList a -> LList a + app xs ys = case xs of + Nill -> case ys of + Nill -> Nill + Conss u us -> ap xs ys + Conss a as -> ap xs ys +-} diff --git a/testsuite/tests/stranal/should_compile/unu.stderr b/testsuite/tests/stranal/should_compile/unu.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/unu.stderr |