{- Starter file for CSE 341, Winter 2014, Haskell Project:
   the Octopus Interpreter -}
 

module OctopusInterpreter
    where

import OctoParser
import Data.Char
import Data.Maybe
import Test.HUnit

{- The heart of the interpreter is the eval function, which takes an
OctoExpr and evaluates it in the given environment.  It is defined by
cases.  

The environment is a list of (name,value) pairs.  The type
'Environment' is a synonym for [(String,OctoExpr)], and is defined in
OctoParser.  To look up a name the interpreter searches the environment
starting from the front, so that one variable can shadow another. -}

eval :: OctoExpr -> Environment -> OctoExpr

-- an integer evaluates to itself
eval (OctoInt i) env = OctoInt i

{- To evaluate a symbol, look it up in the current environment and 
return the value found; or raise an exception if it's not found. -}
eval (OctoSymbol v) env = case lookup v env of
    Nothing -> error ("name not found: " ++ v)
    Just r -> r

-- A quoted expression evaluates to that expression.
eval (OctoList [OctoSymbol "quote", x]) env = x

{- An expression starting with (lambda ...) evaluates to a closure,
where a closure consists of a list of variable names (strings),
the environment of definition, and the body. -}
eval (OctoList [OctoSymbol "lambda", OctoList vars, body]) env = 
    OctoClosure (map getname vars) env body
    where
      getname (OctoSymbol n) = n

{- If we don't match any of the special cases, the first thing in the
list should evaluate to a function.  Apply it to its arguments.  There
are two cases: either the function is a user-defined function, or a
primitive.  These are handled separately.  In either case, the
arguments are found by evaluating each of the expressions after the
function name in the current environment. -}
eval (OctoList (f:xs)) env = case eval f env of
    c@(OctoClosure _ _ _) -> apply c args
    (OctoPrimitive p) -> fromJust (lookup p primitives) $ args
    where  args = map (\x -> eval x env) xs

{- Apply a user-defined function to the given arguments.  The user-defined
function has already been evaluated to get an OctoClosure, and the arguments
have already been evaluated as well in the calling environment.
Then make a new environment by extending the environment of definition
of the lambda (which is part of the closure.  In the extended
environment, the actual args are bound to the respective formal names,
evaluate the body of the function in this new environment, and return
the result. -}
apply (OctoClosure vars f_env body) args = error "TO BE WRITTEN"


-- list of primitive functions and their definitions in Haskell
-- for the starter, we only have + ... you need to add various other functions
primitives = [ ("+",octoplus)]

-- the primitive functions will all get a (Haskell) list of their arguments
-- So the octoplus function takes a list of two OctoInts and adds them.
octoplus :: [OctoExpr] -> OctoExpr
octoplus [OctoInt a, OctoInt b] = OctoInt (a+b)


-- the global enviroment has #t and #f, the primitives, not, null?, and Y
-- we define the primitive_env first so that we can define not and null? in it
primitive_env = [("#t", OctoSymbol "#t"), ("#f", OctoSymbol "#f")] ++
    map (\(name,fn) -> (name, OctoPrimitive name)) primitives

{- For now, just make the global environment be the primitive environment.
After you have lambda working, change it to include the null? function,
and also add the not function. -}
global_env = primitive_env

{- 
Here's the code to use later:
global_env = 
    [("null?", eval (parse "(lambda (x) (equal? x '()))") primitive_env)]
      ++ primitive_env
-}
-- for the unit tests, make a test environment by extending the global env
testenv = [("k", OctoInt 5) , ("s" , OctoSymbol "x")] ++ global_env

evparse s = eval (parse s) testenv

{- unit tests for the interpreter -}
 
test_int  = TestCase (assertEqual "eval an int" (OctoInt 3) (evparse "3"))
test_quoted_atom  = TestCase (assertEqual "eval quoted atom" 
                   (OctoSymbol "x") (evparse "'x"))
test_quoted_list  = TestCase (assertEqual "eval quoted list" 
                   (OctoList [OctoSymbol "x", OctoInt 5]) (evparse "'(x 5)"))
test_lookup1  = TestCase (assertEqual "look up var" (OctoInt 5) (evparse "k"))
test_lookup2  = TestCase (assertEqual "another var" (OctoSymbol "x") (evparse "s"))
test_add  = TestCase (assertEqual "add 2 ints" (OctoInt 7) (evparse "(+ 3 4)"))
test_lambda1  = TestCase (assertEqual "eval lambda" (OctoInt 7) 
                   (evparse "( (lambda (x) x) 7)"))
test_lambda2  = TestCase (assertEqual "apply simple lambda" (OctoInt 17) 
                   (evparse "((lambda (x y) (+ x (+ y 10))) 3 4)"))

-- the inner lambda's y should shadow the outer one, so we get 11 rather than 3
test_shadow  = TestCase (assertEqual "eval shadow" (OctoInt 11) 
                   (evparse "( (lambda (x y) ((lambda (y) (+ x y)) 10)) 1 2)"))

test_let1  = TestCase (assertEqual "eval let1" (OctoInt 7) 
                   (evparse "(let ((x 3)) (+ x 4))"))
test_let2 = TestCase (assertEqual "eval let2" (OctoInt 7) 
                   (evparse "(let ((x 3) (y 4)) (+ x y))"))

nested_let1 = " \
\  (let ((x 3)       \
\        (y 4))      \
\    (let ((x 100))  \
\      (+ x y)))"
test_nested_let1 = TestCase (assertEqual "eval nested let" (OctoInt 104) 
                   (evparse nested_let1))

nested_let2 = " \
\  (let ((x 3)       \
\        (y 4))      \
\    (let ((x (+ x y)))  \
\      (+ x y)))"
test_nested_let2 = TestCase (assertEqual "eval nested let" (OctoInt 11)
                   (evparse nested_let2))

nested_let3 = " \
\  (let ((n 10))                     \
\    (let ((f (lambda (x) (+ x n)))  \
\          (n 3))                    \
\      (+ (f 100) n)))"
test_nested_let3 = TestCase (assertEqual "eval let w fns" (OctoInt 113) 
                   (evparse nested_let3))

{- Test that lambda is closing over its environment of definition.  Here,
n is defined in the let but not where f is used -- so we would get an
error if the body of the lambda were evaluated in the wrong environment. -}
let_test_closure = "                         \
\ (let ((y 10)                               \
\       (f (let ((n 50))                     \
\            (lambda (x) (+ x (* 2 n))))))   \
\   (f y))"
test_closure= TestCase (assertEqual "test closure" (OctoInt 110) 
                   (evparse let_test_closure))

{- The two if cases have a nonexistant variable on the branch not taken.
If we evaluated it we would get an error, so if this works it means
if isn't evaluating the branch not taken. -}
test_if_true = TestCase (assertEqual "eval if true branch" (OctoInt 3) 
                   (evparse "(if #t 3 bad)"))
test_if_false = TestCase (assertEqual "eval if false branch" (OctoInt 5) 
                   (evparse "(if #f bad (+ 2 3))"))

-- bind a new name to a primitive and try it
test_bind_primitive = TestCase (assertEqual "bind +" (OctoInt 7)
                   (evparse "(let ((f +)) (f 3 4))"))

-- rebind * (!!!).  This is a very weird thing to do, but it should work
test_rebind_primitive = TestCase (assertEqual "redefine *" (OctoInt 7)
                   (evparse "(let ((* +)) (* 3 4))"))

-- a simple eval example
test_eval1 = TestCase (assertEqual "simple eval" (OctoInt 5)
                   (evparse "(eval '(+ 2 3))"))

{- more complex eval example -- make sure the argument to eval is evaluated
in the current environment (here with x bound to 10) -}
test_eval2 = TestCase (assertEqual "eval2" (OctoInt 15)
    (evparse "(let ((x 10)) (eval (cons '+ (cons x (cons 5 '())))))"))

{- another complex eval example -- make sure eval evaluates its expression
in the global environment.  To do this, (yuck) rebind * and make sure the 
expression still uses the global * 
(If you don't believe this is legal, try pasting the part between the " marks
into racket and evaluating it.) -}
test_eval3 = TestCase (assertEqual "eval3" (OctoInt 15)
    (evparse "(let ((* null?)) (eval (cons '* (cons 3 (cons 5 '())))))"))



-- *** RECURSIVE FUNCTION TESTS (FOR THE EXTRA CREDIT QUESTION) ***

-- the factorial function
letrec_fact =  " \
\ (letrec       \
\    ((fact (lambda (n) (if (equal? 0 n) 1 (* n (fact (- n 1)))))))   \
\  (fact 4))"

test_factorial = TestCase (assertEqual "eval factorial" (OctoInt 24)
 (evparse letrec_fact))

-- the range function returns a list of integers from n down to 0
letrec_range =  " \
\ (letrec       \
\    ((range (lambda (n) (if (equal? 0 n) '() (cons n (range (- n 1)))))))   \
\  (range 4))"

test_range = TestCase (assertEqual "eval range" (evparse "'(4 3 2 1)")
 (evparse letrec_range))

-- The map function. Since our Y combinator based transformation only handles
-- functions of one argument, we define a curried version of map.  So
-- map itself takes one argument (a function), and returns a new function
-- that maps over a list.
letrec_curried_map =  "                                                     \
\ (letrec                                                                   \
\    ((map (lambda (f)                                                      \
\            (lambda (s)                                                    \
\              (if (null? s) '() (cons (f (car s)) ((map f) (cdr s))))))))  \
\  ((map (lambda (n) (* n 2))) '(10 20 30)))"

test_curried_map = TestCase (assertEqual "eval map" (evparse "'(20 40 60)")
 (evparse letrec_curried_map))

-- no-op test just for terminating the list of tests!
test_no_op = TestCase (assertEqual "no op" "squid" "squid")

-- the tests that don't work yet with the starter program are commented out
tests = TestList [TestLabel "test_int" test_int,
                  TestLabel "test_quoted_atom" test_quoted_atom,
                  TestLabel "test_quoted_list" test_quoted_list,
                  TestLabel "test_lookup1" test_lookup1,
                  TestLabel "test_lookup2" test_lookup2,
                  TestLabel "test_add" test_add,
--                  TestLabel "test_lambda1" test_lambda1,
--                  TestLabel "test_lambda2" test_lambda2,
--                  TestLabel "test_shadow" test_shadow,
--                  TestLabel "test_let1" test_let1,
--                  TestLabel "test_let2" test_let2,
--                  TestLabel "test_nested_let1" test_nested_let1,
--                  TestLabel "test_nested_let2" test_nested_let2,
--                  TestLabel "test_nested_let3" test_nested_let3,
--                  TestLabel "test_closure" test_closure,
--                  TestLabel "test_if_true" test_if_true,
--                  TestLabel "test_if_false" test_if_false,
--                  TestLabel "test_bind_primitive" test_bind_primitive,
--                  TestLabel "test_rebind_primitive" test_rebind_primitive,
--                  TestLabel "test_eval1" test_eval1,
--                  TestLabel "test_eval2" test_eval2,
--                  TestLabel "test_eval3" test_eval3,
--                  TestLabel "test_factorial" test_factorial,
--                  TestLabel "test_range" test_range,
--                  TestLabel "test_curried_map" test_curried_map,
                  TestLabel "test_no_op" test_no_op ]

run = runTestTT tests