1 files changed, 48 insertions, 0 deletions
diff --git a/testsuite/tests/arrows/should_run/arrowrun001.hs b/testsuite/tests/arrows/should_run/arrowrun001.hs
new file mode 100644
index 0000000000..c686b32546
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun001.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE Arrows #-}
+
+-- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5)
+
+module Main(main) where
+
+import Data.Maybe(fromJust)
+import Control.Arrow
+
+type Id = String
+data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a))
+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)
+eval (Add e1 e2) = proc env -> do
+		~(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
+eval (Lam x e) = proc 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
+
+-- some tests
+
+i = Lam "x" (Var "x")
+k = Lam "x" (Lam "y" (Var "x"))
+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")))
+
+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)]))