blob: 825a6249ecc3306e81c889abb85043b2af24eaca (
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
|
module Unlambda.Types (
ULM,
UnlambdaTerm(..),
getResult,
doExit,
setCurChar,
getCurChar
) where
import Control.Exception
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Lazy
import Control.Monad.IO.Class
import Data.Typeable
data UnlambdaException = UnlambdaException { exitTerm :: UnlambdaTerm }
deriving (Show, Typeable)
instance Exception UnlambdaException
type ULM a = ContT UnlambdaTerm (StateT (Maybe Char) IO) a
data UnlambdaTerm = S | K | I | V | R | D | C | E | Bar | Reed
| Dot Char
| Compare Char
| App UnlambdaTerm UnlambdaTerm
| Kpartial UnlambdaTerm
| Spartial UnlambdaTerm
| Sapp UnlambdaTerm UnlambdaTerm
| Promise UnlambdaTerm
| Continuation (UnlambdaTerm -> ULM UnlambdaTerm)
instance Eq UnlambdaTerm where
S == S = True
K == K = True
I == I = True
V == V = True
R == R = True
D == D = True
C == C = True
E == E = True
Bar == Bar = True
Reed == Reed = True
Dot x == Dot y = x == y
Compare x == Compare y = x == y
App a b == App x y = a == x && b == y
Kpartial x == Kpartial y = x == y
Spartial x == Spartial y = x == y
Sapp a b == Sapp x y = a == x && b == y
Promise x == Promise y = x == y
_ == _ = False
instance Show UnlambdaTerm where
show S = "s"
show K = "k"
show I = "i"
show V = "v"
show R = "r"
show D = "d"
show C = "c"
show E = "e"
show Bar = "|"
show Reed = "@"
show (Dot x) = ['.', x]
show (Compare x) = ['?', x]
show (App x y) = "`" ++ (show x) ++ (show y)
show (Kpartial x) = "`k" ++ (show x)
show (Spartial x) = "`s" ++ (show x)
show (Sapp x y) = "``s" ++ (show x) ++ (show y)
show (Promise x) = "`d" ++ (show x)
show (Continuation _) = "<cont>"
getResult :: ULM UnlambdaTerm -> IO UnlambdaTerm
getResult m = catches (liftIO ((`evalStateT` Nothing) . (`runContT` return) $ m))
[ Handler ((\e -> return (exitTerm e)) :: UnlambdaException -> IO UnlambdaTerm) ]
doExit :: UnlambdaTerm -> ULM UnlambdaTerm
doExit term = throw (UnlambdaException term)
setCurChar :: Maybe Char -> ULM ()
setCurChar x = lift (put x)
getCurChar :: ULM (Maybe Char)
getCurChar = lift (get)
|
