{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Language.Unlambda where
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding(catch)
#endif
import Control.Applicative
import Control.Exception (catch, IOException)
import Control.Monad (liftM, ap)
data Exp
= App Exp Exp
| K
| K1 Exp
| S
| S1 Exp
| S2 Exp Exp
| I
| V
| C
| Cont (Cont Exp)
| D
| D1 Exp
| Dot Char
| E
| At
| Ques Char
| Pipe
instance Show Exp where
showsPrec :: Int -> Exp -> ShowS
showsPrec Int
_ = Exp -> ShowS
sh
sh :: Exp -> String -> String
sh :: Exp -> ShowS
sh (App Exp
x Exp
y) = Char -> ShowS
showChar Char
'`' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
y
sh Exp
K = Char -> ShowS
showChar Char
'k'
sh (K1 Exp
x) = String -> ShowS
showString String
"`k" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
x
sh Exp
S = Char -> ShowS
showChar Char
's'
sh (S1 Exp
x) = String -> ShowS
showString String
"`s" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
x
sh (S2 Exp
x Exp
y) = String -> ShowS
showString String
"``s" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
y
sh Exp
I = Char -> ShowS
showChar Char
'i'
sh Exp
V = Char -> ShowS
showChar Char
'v'
sh Exp
C = Char -> ShowS
showChar Char
'c'
sh (Cont Cont Exp
_) = String -> ShowS
showString String
"<cont>"
sh Exp
D = Char -> ShowS
showChar Char
'd'
sh (D1 Exp
x) = String -> ShowS
showString String
"`d" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
x
sh (Dot Char
'\n') = Char -> ShowS
showChar Char
'r'
sh (Dot Char
c) = Char -> ShowS
showChar Char
'.' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
c
sh Exp
E = Char -> ShowS
showChar Char
'e'
sh Exp
At = Char -> ShowS
showChar Char
'@'
sh (Ques Char
c) = Char -> ShowS
showChar Char
'?' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
c
sh Exp
Pipe = Char -> ShowS
showChar Char
'|'
newtype Eval a = Eval ((Maybe Char, Int) -> Cont a -> IO Exp)
type Cont a = (Maybe Char, Int) -> a -> IO Exp
instance Functor Eval where
fmap :: forall a b. (a -> b) -> Eval a -> Eval b
fmap = (a -> b) -> Eval a -> Eval b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative Eval where
pure :: forall a. a -> Eval a
pure = a -> Eval a
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a b. Eval (a -> b) -> Eval a -> Eval b
(<*>) = Eval (a -> b) -> Eval a -> Eval b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Eval where
(Eval (Maybe Char, Int) -> Cont a -> IO Exp
cp1) >>= :: forall a b. Eval a -> (a -> Eval b) -> Eval b
>>= a -> Eval b
f = ((Maybe Char, Int) -> Cont b -> IO Exp) -> Eval b
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (((Maybe Char, Int) -> Cont b -> IO Exp) -> Eval b)
-> ((Maybe Char, Int) -> Cont b -> IO Exp) -> Eval b
forall a b. (a -> b) -> a -> b
$ \(Maybe Char, Int)
dat1 Cont b
cont2 ->
(Maybe Char, Int) -> Cont a -> IO Exp
cp1 (Maybe Char, Int)
dat1 (Cont a -> IO Exp) -> Cont a -> IO Exp
forall a b. (a -> b) -> a -> b
$ \(Maybe Char, Int)
dat2 a
a ->
let (Eval (Maybe Char, Int) -> Cont b -> IO Exp
cp2) = a -> Eval b
f a
a in (Maybe Char, Int) -> Cont b -> IO Exp
cp2 (Maybe Char, Int)
dat2 Cont b
cont2
return :: forall a. a -> Eval a
return a
a = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a)
-> ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
forall a b. (a -> b) -> a -> b
$ \(Maybe Char, Int)
dat Cont a
cont -> Cont a
cont (Maybe Char, Int)
dat a
a
currentChar :: Eval (Maybe Char)
currentChar :: Eval (Maybe Char)
currentChar = ((Maybe Char, Int) -> Cont (Maybe Char) -> IO Exp)
-> Eval (Maybe Char)
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\dat :: (Maybe Char, Int)
dat@(Maybe Char
c,Int
_) Cont (Maybe Char)
cont -> Cont (Maybe Char)
cont (Maybe Char, Int)
dat Maybe Char
c)
setCurrentChar :: Maybe Char -> Eval ()
setCurrentChar :: Maybe Char -> Eval ()
setCurrentChar Maybe Char
c = ((Maybe Char, Int) -> Cont () -> IO Exp) -> Eval ()
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\(Maybe Char
_,Int
i) Cont ()
cont -> Cont ()
cont (Maybe Char
c,Int
i) ())
io :: IO a -> Eval a
io :: forall a. IO a -> Eval a
io IO a
iocp = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\(Maybe Char, Int)
dat Cont a
cont -> IO a
iocp IO a -> (a -> IO Exp) -> IO Exp
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cont a
cont (Maybe Char, Int)
dat)
throw :: ((Maybe Char, Int) -> t -> IO Exp) -> t -> Eval a
throw :: forall t a. ((Maybe Char, Int) -> t -> IO Exp) -> t -> Eval a
throw (Maybe Char, Int) -> t -> IO Exp
c t
x = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\(Maybe Char, Int)
dat Cont a
_ -> (Maybe Char, Int) -> t -> IO Exp
c (Maybe Char, Int)
dat t
x)
exit :: Exp -> Eval a
exit :: forall a. Exp -> Eval a
exit Exp
e = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\(Maybe Char, Int)
_ Cont a
_ -> Exp -> IO Exp
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e)
callCC :: (((Maybe Char, Int) -> a -> IO Exp) -> Eval a) -> Eval a
callCC :: forall a. (((Maybe Char, Int) -> a -> IO Exp) -> Eval a) -> Eval a
callCC ((Maybe Char, Int) -> a -> IO Exp) -> Eval a
f = ((Maybe Char, Int) -> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp)
-> Eval a
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (((Maybe Char, Int)
-> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp)
-> Eval a)
-> ((Maybe Char, Int)
-> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp)
-> Eval a
forall a b. (a -> b) -> a -> b
$ \(Maybe Char, Int)
dat (Maybe Char, Int) -> a -> IO Exp
cont -> let Eval (Maybe Char, Int) -> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp
cp2 = ((Maybe Char, Int) -> a -> IO Exp) -> Eval a
f (Maybe Char, Int) -> a -> IO Exp
cont in (Maybe Char, Int) -> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp
cp2 (Maybe Char, Int)
dat (Maybe Char, Int) -> a -> IO Exp
cont
step :: Eval ()
step :: Eval ()
step = ((Maybe Char, Int) -> Cont () -> IO Exp) -> Eval ()
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\(Maybe Char
c,Int
i) Cont ()
cont -> if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
1 then Exp -> IO Exp
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
E else Cont ()
cont (Maybe Char
c,Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ())
eval :: Exp -> Eval Exp
eval :: Exp -> Eval Exp
eval (App Exp
e1 Exp
e2) = do
Exp
f <- Exp -> Eval Exp
eval Exp
e1
case Exp
f of
Exp
D -> Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
D1 Exp
e2)
Exp
_ -> Exp -> Eval Exp
eval Exp
e2 Eval Exp -> (Exp -> Eval Exp) -> Eval Exp
forall a b. Eval a -> (a -> Eval b) -> Eval b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Exp -> Exp -> Eval Exp
apply Exp
f
eval Exp
e = Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e
apply :: Exp -> Exp -> Eval Exp
apply :: Exp -> Exp -> Eval Exp
apply Exp
K Exp
x = Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
K1 Exp
x)
apply (K1 Exp
x) Exp
_ = Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
apply Exp
S Exp
x = Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
S1 Exp
x)
apply (S1 Exp
x) Exp
y = Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp -> Exp
S2 Exp
x Exp
y)
apply (S2 Exp
x Exp
y) Exp
z = Exp -> Eval Exp
eval (Exp -> Exp -> Exp
App (Exp -> Exp -> Exp
App Exp
x Exp
z) (Exp -> Exp -> Exp
App Exp
y Exp
z))
apply Exp
I Exp
x = Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
apply Exp
V Exp
_ = Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
V
apply Exp
C Exp
x = (Cont Exp -> Eval Exp) -> Eval Exp
forall a. (((Maybe Char, Int) -> a -> IO Exp) -> Eval a) -> Eval a
callCC (Exp -> Exp -> Eval Exp
apply Exp
x (Exp -> Eval Exp) -> (Cont Exp -> Exp) -> Cont Exp -> Eval Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cont Exp -> Exp
Cont)
apply (Cont Cont Exp
c) Exp
x = Cont Exp -> Exp -> Eval Exp
forall t a. ((Maybe Char, Int) -> t -> IO Exp) -> t -> Eval a
throw Cont Exp
c Exp
x
apply Exp
D Exp
x = Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
apply (D1 Exp
e) Exp
x = do Exp
f <- Exp -> Eval Exp
eval Exp
e; Exp -> Exp -> Eval Exp
apply Exp
f Exp
x
apply (Dot Char
c) Exp
x = Eval ()
step Eval () -> Eval () -> Eval ()
forall a b. Eval a -> Eval b -> Eval b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> Eval ()
forall a. IO a -> Eval a
io (Char -> IO ()
putChar Char
c) Eval () -> Eval Exp -> Eval Exp
forall a b. Eval a -> Eval b -> Eval b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp -> Eval Exp
forall a. a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
apply Exp
E Exp
x = Exp -> Eval Exp
forall a. Exp -> Eval a
exit Exp
x
apply Exp
At Exp
f = do
Maybe Char
dat <- IO (Maybe Char) -> Eval (Maybe Char)
forall a. IO a -> Eval a
io (IO (Maybe Char) -> Eval (Maybe Char))
-> IO (Maybe Char) -> Eval (Maybe Char)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Char)
-> (IOException -> IO (Maybe Char)) -> IO (Maybe Char)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((Char -> Maybe Char) -> IO Char -> IO (Maybe Char)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Maybe Char
forall a. a -> Maybe a
Just IO Char
getChar) (\(IOException
_ :: IOException) -> Maybe Char -> IO (Maybe Char)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Char
forall a. Maybe a
Nothing)
Maybe Char -> Eval ()
setCurrentChar Maybe Char
dat
Exp -> Exp -> Eval Exp
apply Exp
f (case Maybe Char
dat of Maybe Char
Nothing -> Exp
V ; Just Char
_ -> Exp
I)
apply (Ques Char
c) Exp
f = do
Maybe Char
cur <- Eval (Maybe Char)
currentChar
Exp -> Exp -> Eval Exp
apply Exp
f (if Maybe Char
cur Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c then Exp
I else Exp
V)
apply Exp
Pipe Exp
f = do
Maybe Char
cur <- Eval (Maybe Char)
currentChar
Exp -> Exp -> Eval Exp
apply Exp
f (case Maybe Char
cur of Maybe Char
Nothing -> Exp
V ; Just Char
c -> Char -> Exp
Dot Char
c)
apply (App Exp
_ Exp
_) Exp
_ = String -> Eval Exp
forall a. HasCallStack => String -> a
error String
"Unknown application"