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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
module pf
import StdArray
import StdBool
import StdFile
from StdFunc import flip, o
import StdMisc
import StdString
import StdTuple
import GenEq
import Control.Applicative
import Control.Monad
import Data.Either
import Data.Error
from Data.Func import $
import Data.Functor
import Data.List
import Data.Maybe
import System.CommandLine
import Yard
:: Expr
= Lambda Ident Expr
| Ident Ident
| Literal Literal
| (@) infixl Expr Expr
:: Literal
= LitInt Int
| LitBool Bool
:: Ident :== String
:: Token
= TBackSlash
| TParenOpen
| TParenClose
| TArrow
| TBool Bool
| TInt Int
| TIdent Ident
derive gEq Token; instance == Token where == a b = a === b
tokenize :: ([Char] -> MaybeError String [Token])
tokenize = flip tok []
where
tok :: [Char] [Token] -> MaybeError String [Token]
tok [] tks = Ok $ reverse tks
tok ['\\':cs] tks = tok cs [TBackSlash:tks]
tok ['(':cs] tks = tok cs [TParenOpen:tks]
tok [')':cs] tks = tok cs [TParenClose:tks]
tok ['-':'>':cs] tks = tok cs [TArrow:tks]
tok ['T':'r':'u':'e':cs] tks = tok cs [TBool True:tks]
tok ['F':'a':'l':'s':'e':cs] tks = tok cs [TBool False:tks]
tok [c:cs] tks
| isSpace c = tok cs tks
| isDigit c = tok rest [TInt (toInt (toString digs)):tks]
with (digs,rest) = span isDigit [c:cs]
| isIdentChar c = tok rest [TIdent (toString ids):tks]
with (ids,rest) = span isIdentChar [c:cs]
| otherwise = Error $ "Unexpected character '" +++ {c} +++ "' in input."
isIdentChar :: Char -> Bool
isIdentChar c = isAlpha c || c == '_'
parse :: String -> MaybeError String Expr
parse s = tokenize (fromString s) >>= cast o runParser expr
where
cast :: (Either String a, [b]) -> MaybeError String a
cast (Right e, []) = Ok e
cast (Right _, _) = Error "Not all input could be consumed."
cast (Left _, _) = Error "Parse error"
simple :: Parser Token Expr
simple = liftM2 lambda (item TBackSlash *> some ident <* item TArrow) expr
<|> Literal <$> LitInt <$> int
<|> Literal <$> LitBool <$> bool
<|> item TParenOpen *> expr <* item TParenClose
<|> Ident <$> ident
where
lambda :: [Ident] Expr -> Expr
lambda [x] e = Lambda x e
lambda [x:xs] e = Lambda x (lambda xs e)
expr :: Parser Token Expr
expr = liftM2 (\f xs -> app [Ident f:xs]) ident (some simple)
<|> simple
where
app :: [Expr] -> Expr
app [e] = e
app es = app (init es) @ last es
ident :: Parser Token Ident
ident = (\(TIdent t) -> t) <$> satisfy (\t -> t=:(TIdent _))
int :: Parser Token Int
int = (\(TInt i) -> i) <$> satisfy (\t -> t=:(TInt _))
bool :: Parser Token Bool
bool = (\(TBool b) -> b) <$> satisfy (\t -> t=:(TBool _))
hasIdent :: Ident Expr -> Bool
hasIdent id (Ident n) = id == n
hasIdent id (Literal _) = False
hasIdent id (Lambda n e) = id <> n && hasIdent id e
hasIdent id (f @ x) = hasIdent id f || hasIdent id x
print :: Expr -> String
print e = foldl (+++) "" (pr False e [])
where
pr :: Bool Expr [String] -> [String]
pr p l=:(Lambda _ _) st =
[if p "(\\" "\\":intersperse " " vars] ++
[" -> ":pr False rhs [if p ")" "":st]]
where
(vars,rhs) = getLambdas l
getLambdas :: Expr -> ([Ident], Expr)
getLambdas (Lambda x rhs) = let (is,e) = getLambdas rhs in ([x:is],e)
getLambdas e = ([], e)
pr _ (Ident id) st = [id:st]
pr _ (Literal l) st = pLit l st
pr p (f @ x) st = [if p "(" "":pr False f [" ":pr True x [if p ")" "":st]]]
pLit :: Literal [String] -> [String]
pLit (LitInt i) st = [toString i:st]
pLit (LitBool b) st = [toString b:st]
optim :: Expr -> Expr
optim (Lambda id e)
| hasIdent id e = case optim e of
Ident id` -> if (id == id`) (Ident "id") (Ident "const" @ e)
e=:(f @ x) -> optim (optApp e)
e -> Lambda id e
| otherwise = Ident "const" @ optim e
where
optApp :: Expr -> Expr
optApp (f @ x) = case moveOutside id (f @ x) of
a=:(f @ Ident id`) -> if (id == id`) f (Ident "const" @ a)
a -> Ident "const" @ a
optim (f @ x) = case optim f @ optim x of
Ident "flip" @ Ident "ap" @ Ident "id" -> Ident "join"
Ident "ap" @ f @ Ident "id" -> optim (Ident "join" @ f)
Ident "join" @ (Ident "(o)" @ f @ g) -> optim (Ident "(>>=)" @ f @ g)
e -> e
optim e = e
moveOutside :: Ident Expr -> Expr
moveOutside _ (Ident id) = Ident id
moveOutside _ (Literal l) = Literal l
moveOutside id (f @ x)
| hasIdent id f && hasIdent id x = Ident "ap" @ Lambda id f @ Lambda id x @ Ident id
| hasIdent id f = case moveOutside id f of
Ident id -> Ident "flip" @ Ident "id" @ x @ Ident id
g @ Ident id -> Ident "flip" @ g @ x @ Ident id
| hasIdent id x = case moveOutside id x of
e=:(Ident id) -> f @ e
g @ e=:(Ident id) -> Ident "(o)" @ f @ g @ e
moveOutside _ (Lambda x e) = Lambda x e // TODO
Start w
# ([prg:cmd],w) = getCommandLine w
| length cmd <> 1 = err ("Usage: " +++ prg +++ " EXPRESSION") w
# e = parse (hd cmd)
| isError e = err (fromError e) w
# e = fromOk e
# (io,w) = stdio w
# io = io <<< "Request: " <<< print e <<< "\n"
# io = io <<< "Result: " <<< print (optim e) <<< "\n"
# (_,w) = fclose io w
= w
where
err :: a *World -> *World | <<< a
err e w = snd (fclose (stderr <<< e <<< "\n") w)
|
