module Eval (eval) where

import Control.Monad.Error
import Data.Maybe (mapMaybe)

import Value

-- type Env = [(String, LispVal)]
-- data ArgSpec = ArgSpec Int Bool
-- type Fun = [LispVal] -> LispVal

pairwise f l = and $ map (uncurry f) $ zip l (tail l)

booleanFun :: (Integer -> Integer -> Bool) -> ([LispVal] -> LispVal)
booleanFun f args = Bool $ pairwise f' args
    where f' (Number a) (Number b) = a `f` b

numericFun :: (Integer -> Integer -> Integer) -> ([LispVal] -> LispVal)
numericFun f args = foldl1 f' args
    where f' (Number a) (Number b) = Number (a `f` b)

-- type Binding = (String, [LispVal] -> LispVal)
type Binding = (String, LispVal)

-- primitives :: [(String, [LispVal] -> LispVal)]
-- primitives :: [Binding]
primitives = [
    ("+", numericFun (+)),
    ("-", numericFun (-)),
    ("*", numericFun (*)),
    ("/", numericFun (div)),
    (">", booleanFun (>)),
    ("not", \(x:[]) -> case x of
        Bool True -> Bool False
        Bool False -> Bool True),
    ("symbol?", \(x:[]) -> case x of
        (Atom _) -> Bool True
        _ -> Bool False),
    ("string?", \(x:[]) -> case x of
        (String _) -> Bool True
        _ -> Bool False),
    ("number?", \(x:[]) -> case x of
        (Number _) -> Bool True
        _ -> Bool False),
    ("symbol->string", \((Atom x):[]) -> String x),
    ("string->symbol", \((String x):[]) -> Atom x),
    ("null?", \(x:[]) -> case x of
        (List []) -> Bool True
        _ -> Bool False),
    ("cons", \(x:y:[]) -> case y of
        (List z) -> List (x:z)
        (DottedList a b) -> DottedList (x:a) b
        _ -> DottedList [x] y),
    ("car", \(x:[]) -> case x of
        (List (x:xs)) -> x
        _ -> Bool False),
    ("cdr", \(x:[]) -> case x of
        (List (x:xs)) -> List xs
        _ -> Bool False)
    ]

apply :: [String] -> [Binding] -> LispVal -> [LispVal] -> Either String LispVal
apply params e expr args = do
    -- why aren't these equivalent?
    -- args' <- mapM (flip eval e >>= return . fst) args
    args' <- mapM (\x -> eval x e >>= return . fst) args
    let args'' = zip params args'
    (v, e') <- eval expr (args'' ++ e)
    return v

eval :: LispVal -> [Binding] -> Either String (LispVal, [Binding])
eval v@(Number _) e = return (v, e)
eval v@(String _) e = return (v, e)
eval v@(Bool _) e = return (v, e)
eval (Atom s) e =
    case lookup s e of
        Nothing -> fail ("'" ++ s ++ "' is undefined")
        Just v -> return (v, e)
eval (List [(Atom "quote"), xs]) e = return (xs, e)
eval (List [(Atom "if"), cond, a, b]) e = case (eval cond e) of
    Right (Bool True, e) -> eval a e
    Right _ -> eval b e
    Left x -> Left x
-- (let () expr)
eval (List [(Atom "let"), (List []), expr]) e = eval expr e
-- (let ((name val) . xs) expr)
eval (List [(Atom "let"), (List ((List [Atom name, val]):xs)), expr]) e = do
    (v, e') <- eval val e
    eval (List [(Atom "let"), (List xs), expr]) ((name, v):e)
eval (List (Atom "let":_)) _ = Left "invalid let form"
-- (lambda (a b c...) ...)
eval (List [(Atom "lambda"), (List params), expr]) e =
    let params' = mapMaybe (\x ->
            case x of
                Atom s -> Just s
                _ -> Nothing) params
    in return (Function params' expr, e)
-- (define ...)
eval (List (Atom "define" : xs)) e =
    case xs of
        [Atom s, expr] -> do
            (v, _) <- eval expr e
            return (Atom s, (s, v) : e)
        [List (Atom s : params), expr] ->
                return (Atom s, (s, Function params' expr) : e)
            where params' = mapMaybe (\x ->
                    case x of
                        Atom s -> Just s
                        _ -> Nothing) params
        _ -> fail "invalid define form"
-- (f ...)
eval (List ((Atom s):args)) e =
    case lookup s primitives of
        Just f' -> do
            args' <- mapM (\x -> eval x e) args
            let args'' = map fst args'
            return (f' args'', e)
        Nothing -> do
            (Function params expr, _) <- eval (Atom s) e
            v <- apply params e expr args
            return (v, e)
-- (expr ...)
eval (List (f:args)) e = do
    (v, e') <- eval f e
    case v of
        Function params expr -> do
            v' <- apply params e expr args
            return (v', e)