gistfile1.hs

module Main where

import IO

type Function = [Atom] -> Atom

type Env = [(String, Atom)]

data Atom = INT Integer
          | REAL Double
          | BOOL Bool
          | SYMBOL String
          | LIST [Atom] 
          | PROC Atom Atom
          | FUNCTION Function

instance Show Atom where
  show (INT i)         = show i
  show (REAL r)        = show r
  show (BOOL b)        = show b
  show (SYMBOL s)      = s
  show (LIST xs)       = (foldl (\s x -> s ++ ' ':show x) "(" xs) ++ " )"
  show (PROC args exp) = "proc " ++ (show args) ++ " " ++ (show exp)
  show (FUNCTION _)    = "function"

lisp_add [INT x,    INT y]    = INT   (x + y)
lisp_add [INT x,    REAL y]   = REAL (fromInteger x + y)
lisp_add [REAL x,   INT y]    = REAL (x + fromInteger y)
lisp_add [REAL x,   REAL y]   = REAL (x + y)

lisp_sub [INT x,  INT y]  = INT   (x - y)
lisp_sub [INT x,  REAL y] = REAL (fromInteger x - y)
lisp_sub [REAL x, INT y]  = REAL (x - fromInteger y)
lisp_sub [REAL x, REAL y] = REAL (x - y)

lisp_mul [INT x,  INT y]  = INT   (x * y)
lisp_mul [INT x,  REAL y] = REAL (fromInteger x * y)
lisp_mul [REAL x, INT y]  = REAL (x * fromInteger y)
lisp_mul [REAL x, REAL y] = REAL (x * y)

lisp_div [INT x,  INT y]  = INT  (x `div` y)
lisp_div [INT x,  REAL y] = REAL (fromInteger x / y)
lisp_div [REAL x, INT y]  = REAL (x / fromInteger y)
lisp_div [REAL x, REAL y] = REAL (x / y)

lisp_not [BOOL x] = BOOL (not x)

lisp_gt  [INT x,    INT y]    = BOOL (x > y)
lisp_gt  [INT x,    REAL y]   = BOOL (fromInteger x > y)
lisp_gt  [REAL x,   INT y]    = BOOL (x > fromInteger y)
lisp_gt  [REAL x,   REAL y]   = BOOL (x > y)
lisp_gt  [BOOL x,   BOOL y]   = BOOL (x > y)
lisp_gt  [SYMBOL x, SYMBOL y] = BOOL (x > y)

lisp_lt  [INT x,    INT y]    = BOOL (x < y)
lisp_lt  [INT x,    REAL y]   = BOOL (fromInteger x < y)
lisp_lt  [REAL x,   INT y]    = BOOL (x < fromInteger y)
lisp_lt  [REAL x,   REAL y]   = BOOL (x < y)
lisp_lt  [SYMBOL x, SYMBOL y] = BOOL (x < y)

lisp_ge  [INT x,    INT y]    = BOOL (x >= y)
lisp_ge  [INT x,    REAL y]   = BOOL (fromInteger x >= y)
lisp_ge  [REAL x,   INT y]    = BOOL (x >= fromInteger y)
lisp_ge  [REAL x,   REAL y]   = BOOL (x >= y)
lisp_ge  [BOOL x,   BOOL y]   = BOOL (x >= y)
lisp_ge  [SYMBOL x, SYMBOL y] = BOOL (x >= y)

lisp_le  [INT x,    INT y]    = BOOL (x <= y)
lisp_le  [INT x,    REAL y]   = BOOL (fromInteger x <= y)
lisp_le  [REAL x,   INT y]    = BOOL (x <= fromInteger y)
lisp_le  [REAL x,   REAL y]   = BOOL (x <= y)
lisp_le  [SYMBOL x, SYMBOL y] = BOOL (x <= y)

lisp_eq  [INT x,    INT y]    = BOOL (x == y)
lisp_eq  [INT x,    REAL y]   = BOOL (fromInteger x == y)
lisp_eq  [REAL x,   INT y]    = BOOL (x == fromInteger y)
lisp_eq  [REAL x,   REAL y]   = BOOL (x == y)
lisp_eq  [SYMBOL x, SYMBOL y] = BOOL (x == y)

lisp_length [LIST x] = INT (toInteger $ length x)

lisp_cons [x, LIST xs] = LIST (x:xs)

lisp_car [LIST (x:xs)] = x

lisp_cdr [LIST (x:xs)] = LIST xs

lisp_append [LIST x, LIST y] = LIST (x ++ y)

lisp_list x = LIST x

lisp_islist [LIST x] = BOOL True
lisp_islist _        = BOOL False

lisp_isnull [LIST []] = BOOL True
lisp_isnull [LIST _]  = BOOL False

lisp_issymbol [SYMBOL _] = BOOL True
lisp_issymbol _          = BOOL False

toAtom fn = FUNCTION fn

global_env :: Env
global_env = [
   ("+",       toAtom lisp_add),
   ("-",       toAtom lisp_sub),
   ("*",       toAtom lisp_mul),
   ("/",       toAtom lisp_div),
   ("not",     toAtom lisp_not),
   (">",       toAtom lisp_gt),
   ("<",       toAtom lisp_lt),
   (">=",      toAtom lisp_ge),
   ("<=",      toAtom lisp_le),
   ("=",       toAtom lisp_eq),
   ("equal?",  toAtom lisp_eq),
   ("length",  toAtom lisp_length),
   ("cons",    toAtom lisp_cons),
   ("car",     toAtom lisp_car),
   ("cdr",     toAtom lisp_cdr),
   ("append",  toAtom lisp_append),
   ("list",    toAtom lisp_list),
   ("list?",   toAtom lisp_islist),
   ("null?",   toAtom lisp_isnull),
   ("symbol?", toAtom lisp_issymbol)
 ]

lisp_if (BOOL True,  _) conseq _   = conseq
lisp_if (BOOL False, _) _      alt = alt

eval (INT i)                                    env = (INT i, env)
eval (REAL r)                                   env = (REAL r, env)
eval (BOOL b)                                   env = (BOOL b, env)
eval (SYMBOL s)                                 env = (case (lookup s env) of Just a -> (a, env))
eval (LIST ((SYMBOL "quote"):a:[]))             env = (a, env)
eval (LIST ((SYMBOL "if"):t:c:a:[]))            env = eval (lisp_if (eval t env) c a) env
eval (LIST ((SYMBOL "set!"):(SYMBOL s):v:[]))   env = case (lookup s env) of 
                                                        Just _ -> let (r, _) = eval v env in (r, (s, r):env)
eval (LIST ((SYMBOL "define"):(SYMBOL s):v:[])) env = let (r, _) = eval v env in (r, (s, r):env)
eval (LIST ((SYMBOL "lambda"):a:e:[]))          env = (PROC a e, env)
eval (LIST ((SYMBOL "begin"):as))               env = foldl (\(_, e) a -> (eval a e)) (LIST [], env) as
eval (LIST as)                                  env =
  case v of
    PROC as exp -> (evalProc as vs exp env, env)
    FUNCTION fn -> (fn vs, env)
    _           -> error $ "ERROR:" ++ (show v)
  where
    ((v:vs), e) = eval' [] as env
    eval' r []     env = (r, env)
    eval' r (a:as) env = let (v, new_env) = eval a env in eval' (r ++ [v]) as new_env
    evalProc (LIST ss) ps exp env = fst $ eval exp ([(s, p) | (SYMBOL s, p) <- zip ss ps] ++ env)

atom token =
  catch (do { i <- readIO token :: IO Integer; return $ INT i })
        (\_ -> catch (do { r <- readIO token :: IO Double; return $ REAL r})
                     (\_ -> return $ SYMBOL token))

read_from :: [String] -> IO Atom
read_from ts = do
  (result, _) <- read_from' ts
  return result

read_from' :: [String] -> IO (Atom, [String])
read_from' ("(":ts) = read_list [] ts
read_from' (")":ts) = error "unexpected"
read_from' (t:ts)   = do { a <- atom t; return (a, ts) }

read_list :: [Atom] -> [String] -> IO (Atom, [String])
read_list as (")":ts) = return (LIST as, ts)
read_list as ts       = do
  (atom, rest)  <- read_from' ts
  read_list (as ++ [atom]) rest

tokenize s = words $ tokenize_ s
  where
    tokenize_ ""       = ""
    tokenize_ ('(':ss) = ' ':'(':' ':(tokenize_ ss)
    tokenize_ (')':ss) = ' ':')':' ':(tokenize_ ss)
    tokenize_ (s:ss)   = s:(tokenize_ ss)

parse :: String -> IO Atom
parse s = read_from $ tokenize s

repl prompt env = do
  putStr prompt
  hFlush stdout
  atom <- parse =<< getLine
  let (result, new_env) = eval atom env
  putStrLn $ show result
  repl prompt new_env

main = repl "lis.hs> " global_env