Testsuite: tabs -> spaces [skip ci]
[ghc.git] / testsuite / tests / arrows / should_run / arrowrun001.hs
1 {-# LANGUAGE Arrows #-}
2
3 -- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5)
4
5 module Main(main) where
6
7 import Data.Maybe(fromJust)
8 import Control.Arrow
9
10 type Id = String
11 data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a))
12 data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp
13
14 eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a)
15 eval (Var s) = proc env ->
16 returnA -< fromJust (lookup s env)
17 eval (Add e1 e2) = proc env -> do
18 ~(Num u) <- eval e1 -< env
19 ~(Num v) <- eval e2 -< env
20 returnA -< Num (u + v)
21 eval (If e1 e2 e3) = proc env -> do
22 ~(Bl b) <- eval e1 -< env
23 if b then eval e2 -< env
24 else eval e3 -< env
25 eval (Lam x e) = proc env ->
26 returnA -< Fun (proc v -> eval e -< (x,v):env)
27 eval (App e1 e2) = proc env -> do
28 ~(Fun f) <- eval e1 -< env
29 v <- eval e2 -< env
30 f -<< v
31
32 -- some tests
33
34 i = Lam "x" (Var "x")
35 k = Lam "x" (Lam "y" (Var "x"))
36 double = Lam "x" (Add (Var "x") (Var "x"))
37
38 -- if b then k (double x) x else x + x + x
39
40 text_exp = If (Var "b")
41 (App (App k (App double (Var "x"))) (Var "x"))
42 (Add (Var "x") (Add (Var "x") (Var "x")))
43
44 unNum (Num n) = n
45
46 main = do
47 print (unNum (eval text_exp [("b", Bl True), ("x", Num 5)]))
48 print (unNum (eval text_exp [("b", Bl False), ("x", Num 5)]))