Add tests for solved arrow tickets #5777 #15175wip/test-arrows

Merge requests !4464 and !4474 fixed the Lint problems.

Closes #5777.
Closes #15175.

3 files changed, 79 insertions, 0 deletions

diff --git a/testsuite/tests/arrows/should_compile/T15175.hs b/testsuite/tests/arrows/should_compile/T15175.hs
new file mode 100644
index 0000000000..af396dfa95
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/T15175.hs
@@ -0,0 +1,64 @@
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE GADTs #-}
+
+module T15175 (
+    gun,        -- :: Position2 -> Object
+) where
+
+import Control.Arrow
+import Control.Category (Category)
+
+data Point2 a = RealFloat a => Point2 !a !a
+
+gun :: Point2 Double -> Object
+gun (Point2 x0 y0) = proc (ObjInput {oiGameInput = gi}) -> do
+    (Point2 xd _) <- ptrPos -< gi               -- This line can't be removed
+
+    let x = undefined
+        v = undefined
+        fire = undefined :: Double
+
+    returnA -< ObjOutput {
+                   ooSpawnReq    =
+                       fire `tag` [missile (Point2 x (y0 + (0/2)))
+                                           (vector2 v (200 :: Double))]
+               }
+
+vector2 = undefined
+
+tag = undefined
+
+ptrPos = undefined
+
+missile = undefined
+
+-- | Creates a feedback loop without delay.
+instance Category SF where
+
+instance ArrowLoop SF where
+
+instance Arrow SF where
+
+data SF' a b where
+    SF' :: !(DTime -> a -> Transition a b) -> SF' a b
+
+type Transition a b = (SF' a b, b)
+
+data SF a b = SF {sfTF :: a -> Transition a b}
+
+type DTime = Double     -- [s]
+
+data Event a = Event a deriving (Show)
+
+type Object = SF ObjInput ObjOutput
+
+data ObjInput = ObjInput {
+    oiGameInput :: GameInput
+}
+
+data ObjOutput = ObjOutput {
+    ooSpawnReq    :: Event [Object]
+}
+
+data GameInput = GameInput
diff --git a/testsuite/tests/arrows/should_compile/T5777.hs b/testsuite/tests/arrows/should_compile/T5777.hs
new file mode 100644
index 0000000000..697473a4a4
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/T5777.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE Arrows, GADTs #-}
+module T5777 where
+
+import Control.Arrow
+
+data Value a where BoolVal :: Value Bool
+
+class ArrowInit f where
+    arrif :: f b -> ()
+
+instance ArrowInit Value where
+    arrif = proc BoolVal -> returnA -< ()
+    -- arrif = arr (\BoolVal -> ())
diff --git a/testsuite/tests/arrows/should_compile/all.T b/testsuite/tests/arrows/should_compile/all.T
index a399006aae..f636903a0a 100644
--- a/testsuite/tests/arrows/should_compile/all.T
+++ b/testsuite/tests/arrows/should_compile/all.T
@@ -18,3 +18,5 @@ test('T5022', normalise_fun(normalise_errmsg), compile, [''])
 test('T5333', normal, compile, [''])
 test('T17423', normal, compile, [''])
 test('T18950', normal, compile, [''])
+test('T5777', normal, compile, [''])
+test('T15175', normal, compile, [''])