blob: b1658873cd69c990d4f85cf3a7922144f9301880 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
module Unlambda.Interpreter (
unlambda
) where
import System.IO.Error
import Control.Monad.Trans.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.State.Lazy
import Control.Monad.IO.Class
import Unlambda.Parser
type ULM a = ContT UnlambdaTerm (StateT UnlambdaState IO) a
data UnlambdaState = UnlambdaState { exit :: UnlambdaTerm -> ULM UnlambdaTerm
, curChar :: Maybe Char }
unlambda :: UnlambdaTerm -> IO UnlambdaTerm
unlambda term = (`getResult` return) (callCC $ \cont -> setExit cont >> setCurChar Nothing >> eval term)
getResult :: (Monad m) => ULM a -> (a -> m a) -> m a
getResult m f = f . runStateT . runContT $ m
setExit :: (UnlambdaTerm -> ULM UnlambdaTerm) -> ULM ()
setExit cont = do
state <- lift get
(lift put) (state { exit = cont })
return
doExit :: UnlambdaTerm -> ULM UnlambdaTerm
doExit term = do
state <- lift get
(exit state) term
return
setCurChar :: Maybe Char -> ULM ()
setCurChar ch = do
state <- lift get
(lift put) (state { curChar = ch })
return
getCurChar :: ULM (Maybe Char)
getCurChar = do
state <- lift get
return (curChar state)
eval :: UnlambdaTerm -> ULM UnlambdaTerm
eval term =
case term of
App f x -> do
t <- eval f
apply t x
_ -> return term
apply :: UnlambdaTerm -> UnlambdaTerm -> ULM UnlambdaTerm
apply firstTerm secondTerm =
case firstTerm of
K -> eval secondTerm >>= return . Kpartial
Kpartial x -> eval secondTerm >> return x
S -> eval secondTerm >>= return . Spartial
Spartial x -> eval secondTerm >>= return . (Sapp x)
Sapp x y -> do
z <- eval secondTerm
eval (App (App x z) (App y z))
I -> eval secondTerm
V -> eval secondTerm >> return V
C -> callCC $ \cont -> eval (App secondTerm (Continuation cont))
Continuation cont -> eval secondTerm >>= cont
D -> return (Promise secondTerm)
Promise x -> eval secondTerm >>= eval . (App x)
Dot c -> do
t <- eval secondTerm
liftIO (putChar c)
return t
R -> do
t <- eval secondTerm
liftIO (putChar '\n')
return t
E -> eval secondTerm >>= doExit
Reed -> return I --do
--t <- eval ch secondTerm
--catchIOError (do
-- ch' <- getChar
-- eval (Just ch') (App t I)
-- ) (\e -> eval Nothing (App t V))
Bar -> return I --do
--t <- eval ch secondTerm
--case ch of
-- Just x -> eval ch (App t (Dot x))
-- Nothing -> eval ch (App t V)
Compare c -> return I --do
--t <- eval ch secondTerm
--case (ch == Just c) of
-- True -> eval ch (App t I)
-- False -> eval ch (App t V)
|
