{-# LANGUAGE FlexibleContexts, LambdaCase #-}

module Scheme.Runtime where

import Scheme.Core
import Scheme.Parse
import Scheme.Eval

import qualified Data.HashMap.Strict as H
import Text.ParserCombinators.Parsec hiding (Parser, State)
import Control.Monad
import Control.Monad.State
import Control.Monad.Except
import Data.Foldable

--- ### Helper functions for lifting and lowering

lowerBool :: Val -> Bool
lowerBool (Boolean False) = False
lowerBool _ = True

lowerInt :: Val -> EvalState Int
lowerInt (Number i) = return i
lowerInt v = throwError $ TypeError v

lowerList :: Val -> EvalState [Val]
lowerList (List xx) = return xx
lowerList v = throwError $ TypeError v

liftIntVargOp :: (Int -> Int -> Int) -> Int -> Val
liftIntVargOp f c = PrimFunc p where
  p [] = return $ Number c
  p [x] = Number . f c <$> lowerInt x
  p xx = Number . foldl1 f <$> mapM lowerInt xx

liftBoolVargOp :: ([Bool] -> Bool) -> Val
liftBoolVargOp f = PrimFunc $ return . Boolean . f . map lowerBool

liftIntBinOp :: (Int -> Int -> Int) -> Val
liftIntBinOp f = PrimFunc p where
  p [Number x, Number y] = return $ Number $ f x y
  p v = throwError $ UnexpectedArgs v

liftIntUnaryOp :: (Int -> Int) -> Val
liftIntUnaryOp f = PrimFunc p where
  p [Number x] = return $ Number $ f x
  p v = throwError $ UnexpectedArgs v

liftBoolUnaryOp :: (Bool -> Bool) -> Val
liftBoolUnaryOp f = PrimFunc p where
  p [Boolean False] = return $ Boolean $ f False
  p [_] = return $ Boolean $ f True
  p v = throwError $ UnexpectedArgs v

liftCompOp :: (Int -> Int -> Bool) -> Val
liftCompOp f = PrimFunc p where
  p [] = return $ Boolean True
  p xx = mapM lowerInt xx >>= \nums ->
    return . Boolean . and . map (uncurry f) $ zip nums (tail nums)

--- ### Primtive operations

-- Primitive function `car`
car :: [Val] -> EvalState Val
car [List (x:_)] = return x
car [DottedList (x:_) _] = return x
car vv = throwError $ UnexpectedArgs vv

-- Primitive function `cdr`
cdr :: [Val] -> EvalState Val
cdr [List (_:xs)] = return $ List xs
cdr [DottedList [_] y] = return y
cdr [DottedList (_:xs) y] = return $ DottedList xs y
cdr vv = throwError $ UnexpectedArgs vv

-- Primitive function `cons`
cons :: [Val] -> EvalState Val
cons [x, y] = return $ DottedList [x] y
cons vv = throwError $ UnexpectedArgs vv

-- Primitive function `append`
append :: [Val] -> EvalState Val
append [] = return $ List []
append [x] = return x
append vv = foldlM append' (List []) (map flattenList vv) where
  append' (List []) x = return x
  append' (List xs) (List ys) = return $ List (xs ++ ys)
  append' (List xs) (DottedList ys y) = return $ DottedList (xs ++ ys) y
  append' _ acc = throwError $ TypeError acc

-- Primitive function `apply`
-- It applies a function to a list of parameters
-- Examples:
--   (apply + '(1 2 3))  => 6
--   (apply car '((1 2 3)))  => 1
applyPrim :: [Val] -> EvalState Val
applyPrim [f, args] = case flattenList args of
  List xx -> apply f xx
  v -> throwError $ TypeError v
applyPrim vv = throwError $ UnexpectedArgs vv

-- Primitive function `eval`
-- It evaluates the single argument as an expression
-- All you have to do is to check the number of arguments and
-- feed the single argument to the evaluator!
-- Examples:
--   (eval '(+ 1 2 3))  => 6
evalPrim :: [Val] -> EvalState Val
evalPrim [e] = eval e
evalPrim vv = throwError $ UnexpectedArgs vv

-- Primitive function `=`, throwing type error for mismatch
-- `=` is a comparison operator for numbers and booleans
-- Examples:
--   (= 1 1) => #t
--   (= #f #t) => #f
--   (= #f #f) => #t
--   (= 'a 10) => Type error
--   (= 'a 'b) => Type error
equalSign :: [Val] -> EvalState Val
equalSign [] = return $ Boolean True
equalSign [x] = return $ Boolean True
equalSign l@(x:xs) = equalSignTypeValid l >> equalSignVal l
equalSignTypeValid :: [Val] -> EvalState Val
equalSignTypeValid [] = return $ Boolean True
equalSignTypeValid [x] = return $ Boolean True
equalSignTypeValid l@(x:xs) =
  let same_type (a,b) = case (a,b) of
        ((Number _),(Number _)) -> return $ Boolean True
        ((Boolean _),(Boolean _)) -> return $ Boolean True
        (x,y) -> throwError $ TypeError y
      pairs = zip l (tail l)
      check_pairs [] = return $ Boolean True
      check_pairs ((a,b):xs) = same_type (a,b) >> check_pairs xs
  in check_pairs pairs
equalSignVal :: [Val] -> EvalState Val
equalSignVal [] = return $ Boolean True
equalSignVal [x] = return $ Boolean True
equalSignVal (x:xs) = Boolean <$> foldlM (equal' x) True xs where
  equal' _ False _ = return False
  equal' (Number a) _ (Number b) = return $ a == b
  equal' (Boolean a) _ (Boolean b) = return $ a == b
  equal' y _ _ = throwError $ TypeError y

-- Primitive function `eq?`, not throwing any error
-- `eq?` is a comparison operator for atom values (numbers, booleans, and symbols)
-- Returns `#f` on type mismatch or unsupported types (functions etc)
-- Examples:
--   (eq? 1 1) => #t
--   (eq? #f #t) => #f
--   (eq? #f #f) => #t
--   (eq? 'a 10) => #f
--   (eq? 'a 'a) => #t
eq :: [Val] -> EvalState Val
eq [] = return $ Boolean True
eq (x:xs) = return $ Boolean $ foldl (eq' x) True xs where
  eq' _ False _ = False
  eq' (Number a) _ (Number b) = a == b
  eq' (Boolean a) _ (Boolean b) = a == b
  eq' (Symbol a) _ (Symbol b) = a == b
  eq' _ _ _ = False

-- Primitive function `symbol?` predicate
isSymbol :: [Val] -> EvalState Val
isSymbol [Symbol _] = return $ Boolean True
isSymbol [_] = return $ Boolean False
isSymbol vv = throwError $ UnexpectedArgs vv

-- Primitive function `list?` predicate
isList :: [Val] -> EvalState Val
isList [v] =
  return . Boolean $ case flattenList v of
    List _ -> True
    _ -> False
isList vv = throwError $ UnexpectedArgs vv

-- Primitive function `pair?` predicate
isPair :: [Val] -> EvalState Val
isPair [v] =
  return . Boolean $ case flattenList v of
    List (_:_) -> True
    DottedList _ _ -> True
    _ -> False
isPair vv = throwError $ UnexpectedArgs vv

-- Primitive function `isNumber?` predicate
isNumber :: [Val] -> EvalState Val
isNumber [Number _] = return $ Boolean True
isNumber [_] = return $ Boolean False
isNumber vv = throwError $ UnexpectedArgs vv

-- Primitive function `isBoolean?` predicate
isBoolean :: [Val] -> EvalState Val
isBoolean [Boolean _] = return $ Boolean True
isBoolean [_] = return $ Boolean False
isBoolean vv = throwError $ UnexpectedArgs vv

-- Primitive function `null?` predicate
isNull :: [Val] -> EvalState Val
isNull [v] =
  return . Boolean $ case flattenList v of
    List [] -> True
    _ -> False
isNull vv = throwError $ UnexpectedArgs vv

--- ### Runtime

runtime :: Env
runtime = H.fromList [ ("+", liftIntVargOp (+) 0)
                     , ("-", liftIntVargOp (-) 0)
                     , ("*", liftIntVargOp (*) 1)
                     , ("/", liftIntVargOp div 1)
                     , (">", liftCompOp (>))
                     , (">=", liftCompOp (>=))
                     , ("<", liftCompOp (<))
                     , ("<=", liftCompOp (<=))
                     , ("or",  liftBoolVargOp or)
                     , ("and",  liftBoolVargOp and)
                     , ("modulo", liftIntBinOp mod)
                     , ("abs", liftIntUnaryOp abs)
                     , ("not", liftBoolUnaryOp not)
                     , ("car", PrimFunc car)
                     , ("cdr", PrimFunc cdr)
                     , ("cons", PrimFunc cons)
                     , ("list", PrimFunc $ return . List)
                     , ("append", PrimFunc append)
                     , ("apply", PrimFunc applyPrim)
                     , ("=", PrimFunc equalSign)
                     , ("eq?", PrimFunc eq)
                     , ("symbol?", PrimFunc isSymbol)
                     , ("list?", PrimFunc isList)
                     , ("pair?", PrimFunc isPair)
                     , ("number?", PrimFunc isNumber)
                     , ("boolean?", PrimFunc isBoolean)
                     , ("null?", PrimFunc isNull)
                     , ("eval", PrimFunc evalPrim)
                     ]