{-
 - 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>
 -                                                                           
 - 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 -}

import qualified Char
import qualified IO
import qualified System

data Expression =
  Appl Expression Expression |
  K | K1 Expression |
  S | S1 Expression | S2 Expression Expression |
  I | V |
  C | Cont (Cont Expression) |
  D | D1 Expression |
  Dot Char | E | At | Ques Char | Pipe

-- Parsing of the Unlambda program (in the IO monad)

parseExpr :: IO.Handle -> IO Expression
parseExpr h = do
  op <- IO.hGetChar h
  case Char.toLower op of
    '`' -> do
      e1 <- parseExpr h
      e2 <- parseExpr h
      return (Appl e1 e2)
    ' ' -> parseExpr h
    '\t' -> parseExpr h
    '\n' -> parseExpr h
    '#' -> do IO.hGetLine h; parseExpr h
    'k' -> return K
    's' -> return S
    'i' -> return I
    'v' -> return V
    'c' -> return C
    'd' -> return D
    '.' -> do c <- IO.hGetChar h; return (Dot c)
    'r' -> return (Dot '\n')
    'e' -> return E
    '@' -> return At
    '?' -> do c <- IO.hGetChar h; return (Ques c)
    '|' -> return Pipe
    _ -> error ("Unknown operator " ++ [op])

-- Printing of Unlambda expressions

instance Show Expression where
  showsPrec _ e = sh e

sh (Appl x y) = showChar '`' . sh x . sh y
sh K          = showChar 'k'
sh (K1 x)     = showString "`k" . sh x
sh S          = showChar 's'
sh (S1 x)     = showString "`s" . sh x
sh (S2 x y)   = showString "``s" . sh x . sh y
sh I          = showChar 'i'
sh V          = showChar 'v'
sh C          = showChar 'c'
sh (Cont _)   = showString "<cont>"
sh D          = showChar 'd'
sh (D1 x)     = showString "`d" . sh x
sh (Dot '\n') = showChar 'r'
sh (Dot c)    = showChar '.' . showChar c
sh E          = showChar 'e'
sh At         = showChar '@'
sh (Ques c)   = showChar '?' . showChar c
sh Pipe       = showChar '|'

-- Definition of the runtime computation monad

type CompData = Maybe Char

newtype Computation a =
-- newtype required in order to add the type to a class
  Computation (CompData -> Cont a -> IO Expression)

type Cont a = CompData -> a -> IO Expression

instance Monad Computation where

  (Computation cp1) >>= f = Computation cp where
    cp dat1 cont2 = cp1 dat1 cont1 where
      cont1 dat2 a = cp2 dat2 cont2 where
        (Computation cp2) = f a

  return a = Computation cp where
    cp dat cont = cont dat a

-- Basic computation definitions

currentChar = Computation cp where
  cp dat cont = cont dat dat
setCurrentChar c = Computation cp where
  cp dat cont = cont c ()

io iocp = Computation cp where
  cp dat cont = do
    a <- iocp
    cont dat a

callCC f = Computation cp where
  cp dat cont = cp2 dat cont where
    (Computation cp2) = f cont
throw c x = Computation cp where
  cp dat cont = c dat x

exit e = Computation cp where
  cp _ _ = return e

-- Interpretation in the Computation monad

eval (Appl e1 e2) = do
  f <- eval e1
  case f of
    D -> return (D1 e2)
    _ -> do g <- eval e2; apply f g
eval e = return e

apply K x = return (K1 x)
apply (K1 x) y = return x
apply S x = return (S1 x)
apply (S1 x) y = return (S2 x y)
apply (S2 x y) z = eval (Appl (Appl x z) (Appl y z))
apply I x = return x
apply V x = return V
apply C x = callCC f where
  f c = apply x (Cont c)
apply (Cont c) x = throw c x
apply D x = return x
apply (D1 e) x = do
  f <- eval e
  apply f x
apply (Dot c) x = do
  io (putChar c)
  return x
apply E x = exit x
apply At f = do
  dat <- io (
    (do ch <- IO.getChar; return (Just ch))
    `catch` \_ -> return Nothing)
  setCurrentChar dat
  case dat of
    Nothing -> apply f V
    Just _ -> apply f I
apply (Ques c) f = do
  cur <- currentChar
  if cur == Just c
    then apply f I
    else apply f V
apply Pipe f = do
  cur <- currentChar
  case cur of
    Nothing -> apply f V
    Just c -> apply f (Dot c)

-- A class for describing program source

class ExpressionSource s where
  toExpression :: s -> IO Expression

instance ExpressionSource Expression where
  toExpression e = return e

instance ExpressionSource IO.Handle where
  toExpression h = parseExpr h

newtype Filename = FN String

instance ExpressionSource Filename where
  toExpression (FN fn) = IO.openFile fn IO.ReadMode >>= toExpression

--

interpret prog = do
  exp <- toExpression prog
  let
    (Computation cp) = eval exp
    cont dat a = return a
  cp Nothing cont

rep prog = interpret prog >>= print

getProgramHandle = do
  args <- System.getArgs
  case args of
    [] -> return IO.stdin
    [fn] -> IO.openFile fn IO.ReadMode

main = getProgramHandle >>= interpret