{-# 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 _ = Exp -> ShowS
sh
sh :: Exp -> String -> String
sh :: Exp -> ShowS
sh (App x :: Exp
x y :: Exp
y) = Char -> ShowS
showChar '`' 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 K = Char -> ShowS
showChar 'k'
sh (K1 x :: Exp
x) = String -> ShowS
showString "`k" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
x
sh S = Char -> ShowS
showChar 's'
sh (S1 x :: Exp
x) = String -> ShowS
showString "`s" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
x
sh (S2 x :: Exp
x y :: Exp
y) = String -> ShowS
showString "``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 I = Char -> ShowS
showChar 'i'
sh V = Char -> ShowS
showChar 'v'
sh C = Char -> ShowS
showChar 'c'
sh (Cont _) = String -> ShowS
showString "<cont>"
sh D = Char -> ShowS
showChar 'd'
sh (D1 x :: Exp
x) = String -> ShowS
showString "`d" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
sh Exp
x
sh (Dot '\n') = Char -> ShowS
showChar 'r'
sh (Dot c :: Char
c) = Char -> ShowS
showChar '.' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
c
sh E = Char -> ShowS
showChar 'e'
sh At = Char -> ShowS
showChar '@'
sh (Ques c :: Char
c) = Char -> ShowS
showChar '?' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
c
sh Pipe = Char -> ShowS
showChar '|'
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 :: (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 :: a -> Eval a
pure = a -> Eval a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: 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 cp1 :: (Maybe Char, Int) -> Cont a -> IO Exp
cp1) >>= :: Eval a -> (a -> Eval b) -> Eval b
>>= f :: 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
$ \dat1 :: (Maybe Char, Int)
dat1 cont2 :: 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
$ \dat2 :: (Maybe Char, Int)
dat2 a :: a
a ->
let (Eval cp2 :: (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 :: a -> Eval a
return a :: 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
$ \dat :: (Maybe Char, Int)
dat cont :: 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@(c :: Maybe Char
c,_) cont :: Cont (Maybe Char)
cont -> Cont (Maybe Char)
cont (Maybe Char, Int)
dat Maybe Char
c)
setCurrentChar :: Maybe Char -> Eval ()
setCurrentChar :: Maybe Char -> Eval ()
setCurrentChar c :: Maybe Char
c = ((Maybe Char, Int) -> Cont () -> IO Exp) -> Eval ()
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\(_,i :: Int
i) cont :: Cont ()
cont -> Cont ()
cont (Maybe Char
c,Int
i) ())
io :: IO a -> Eval a
io :: IO a -> Eval a
io iocp :: IO a
iocp = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\dat :: (Maybe Char, Int)
dat cont :: Cont a
cont -> IO a
iocp IO a -> (a -> IO Exp) -> IO Exp
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 :: ((Maybe Char, Int) -> t -> IO Exp) -> t -> Eval a
throw c :: (Maybe Char, Int) -> t -> IO Exp
c x :: t
x = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\dat :: (Maybe Char, Int)
dat _ -> (Maybe Char, Int) -> t -> IO Exp
c (Maybe Char, Int)
dat t
x)
exit :: Exp -> Eval a
exit :: Exp -> Eval a
exit e :: Exp
e = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
Eval (\_ _ -> Exp -> IO Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e)
callCC :: (((Maybe Char, Int) -> a -> IO Exp) -> Eval a) -> Eval a
callCC :: (((Maybe Char, Int) -> a -> IO Exp) -> Eval a) -> Eval a
callCC f :: ((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
$ \dat :: (Maybe Char, Int)
dat cont :: (Maybe Char, Int) -> a -> IO Exp
cont -> let Eval cp2 :: (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 (\(c :: Maybe Char
c,i :: Int
i) cont :: Cont ()
cont -> if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<1 then Exp -> IO Exp
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
-1) ())
eval :: Exp -> Eval Exp
eval :: Exp -> Eval Exp
eval (App e1 :: Exp
e1 e2 :: Exp
e2) = do
Exp
f <- Exp -> Eval Exp
eval Exp
e1
case Exp
f of
D -> Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
D1 Exp
e2)
_ -> Exp -> Eval Exp
eval Exp
e2 Eval Exp -> (Exp -> Eval Exp) -> Eval Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Exp -> Exp -> Eval Exp
apply Exp
f
eval e :: Exp
e = Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e
apply :: Exp -> Exp -> Eval Exp
apply :: Exp -> Exp -> Eval Exp
apply K x :: Exp
x = Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
K1 Exp
x)
apply (K1 x :: Exp
x) _ = Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
apply S x :: Exp
x = Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
S1 Exp
x)
apply (S1 x :: Exp
x) y :: Exp
y = Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp -> Exp
S2 Exp
x Exp
y)
apply (S2 x :: Exp
x y :: Exp
y) z :: 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 I x :: Exp
x = Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
apply V _ = Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
V
apply C x :: Exp
x = (((Maybe Char, Int) -> Exp -> IO 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)
-> (((Maybe Char, Int) -> Exp -> IO Exp) -> Exp)
-> ((Maybe Char, Int) -> Exp -> IO Exp)
-> Eval Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Char, Int) -> Exp -> IO Exp) -> Exp
Cont)
apply (Cont c :: (Maybe Char, Int) -> Exp -> IO Exp
c) x :: Exp
x = ((Maybe Char, Int) -> Exp -> IO Exp) -> Exp -> Eval Exp
forall t a. ((Maybe Char, Int) -> t -> IO Exp) -> t -> Eval a
throw (Maybe Char, Int) -> Exp -> IO Exp
c Exp
x
apply D x :: Exp
x = Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
apply (D1 e :: Exp
e) x :: Exp
x = do Exp
f <- Exp -> Eval Exp
eval Exp
e; Exp -> Exp -> Eval Exp
apply Exp
f Exp
x
apply (Dot c :: Char
c) x :: Exp
x = Eval ()
step Eval () -> Eval () -> Eval ()
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp -> Eval Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
apply E x :: Exp
x = Exp -> Eval Exp
forall a. Exp -> Eval a
exit Exp
x
apply At f :: 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 (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 (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 Nothing -> Exp
V ; Just _ -> Exp
I)
apply (Ques c :: Char
c) f :: 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 Pipe f :: Exp
f = do
Maybe Char
cur <- Eval (Maybe Char)
currentChar
Exp -> Exp -> Eval Exp
apply Exp
f (case Maybe Char
cur of Nothing -> Exp
V ; Just c :: Char
c -> Char -> Exp
Dot Char
c)
apply (App _ _) _ = String -> Eval Exp
forall a. HasCallStack => String -> a
error "Unknown application"