{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-
Uses pattern guards

This is an interpreter of the Unlambda language, written in
the pure, lazy, functional language Haskell.

Copyright (C) 2001 by Ørjan Johansen <oerjan@nvg.ntnu.no>
Copyright (C) 2006 by Don Stewart - http://www.cse.unsw.edu.au/~dons

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
-}

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)

------------------------------------------------------------------------
-- Abstract syntax

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

------------------------------------------------------------------------
-- Printing

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 '|'

------------------------------------------------------------------------
-- Eval monad

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

------------------------------------------------------------------------
-- Basics

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) ())

------------------------------------------------------------------------
-- Interpretation in the Eval monad

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"