module VirtualMachine.VM where

import Text.Printf (printf)
import Data.Foldable (toList)
import Control.Monad.Trans (lift)
import Control.Monad.Except (throwError)
import Control.Monad.Trans.State (StateT)
import Control.Monad.Trans.Except (ExceptT)
import qualified Data.Sequence as S
import qualified Control.Monad.State as ST (get, put)
import Data.Functor ((<&>))
import Control.Monad (unless)


data VM = VM { _pc    :: Int
             , _fp    :: Int
             , _stack :: S.Seq Int
             , _halt  :: Bool
             , _debug :: Bool
             } deriving (Eq)

instance Show VM where
  show vm = printf "%s PC=%03d FP=%03d Stack=%s" (if _halt vm then "\x25A0" else "\x25B6") (_pc vm) (_fp vm) (show $ toList $ _stack vm)

data Op = Nop  -- 0x00 
        | Halt -- 0x01
        | Push -- 0x02
        | Pop  -- 0x03
        | Dup  -- 0x04
        | Swap -- 0x05
        | Add  -- 0x06
        | Sub  -- 0x07
        | Mul  -- 0x08
        | Div  -- 0x09
        | Neg  -- 0x0a
        | Not  -- 0x0b
        | Call -- 0x0c
        | Ret  -- 0x0d
        | Jmp  -- 0x0e
        | Je   -- 0x0f
        | Jne  -- 0x10
        | Jg   -- 0x11
        | Jl   -- 0x12
        | Jge  -- 0x13
        | Jle  -- 0x14
        | Lda  -- 0x15
        | In   -- 0x16
        | Out  -- 0x17
        | Clr  -- 0x18
        | Over -- 0x19
        | Ldl  -- 0x1A
        | Stl  -- 0x1B
        deriving (Eq, Ord, Enum, Show, Read, Bounded)

type Machine = StateT VM IO

type Computation = ExceptT String Machine

empty :: VM
empty = VM { _pc     = 0
           , _fp     = -1
           , _stack  = S.empty
           , _halt   = False
           , _debug  = False
           }

-------------------------------------------------------------------------------

get :: Computation VM
get = lift ST.get

put :: VM -> Computation ()
put x = lift $ ST.put x

getPc :: Computation Int
getPc = get <&> _pc

getFp :: Computation Int
getFp = get <&> _fp

isHalted :: Computation Bool
isHalted = get <&> _halt

isDebug :: Computation Bool
isDebug = get <&> _debug

stackAt :: Int -> String -> Computation Int
stackAt index err = get >>= \vm -> case _stack vm S.!? index of
  (Just i) -> return i
  Nothing  -> throwError err

frameAt :: Int -> (Int -> Int) -> String -> Computation Int
frameAt index t name = do
  vm <- get
  fp <- getFp
  unless (fp > -1) (throwError "No active stack frame")
  stackSize <- getStackSize
  case _stack vm S.!? (stackSize - fp - 1 - t index) of
    (Just i) -> return i
    Nothing  -> throwError $ "Cannot determine " ++ name ++ " - index " ++ show index ++ " out of frame bounds"

updateFrameAt :: Int -> Int -> Computation ()
updateFrameAt index value = do
  vm <- get
  fp <- getFp
  unless (fp > -1) (throwError "No active stack frame")
  stackSize <- getStackSize
  put vm { _stack = S.update (stackSize - fp - 1 - index) value $ _stack vm }

getStackSize :: Computation Int
getStackSize = get <&> (length . _stack)

setPc :: Int -> Computation ()
setPc pc = get >>= \vm -> put vm { _pc = pc }

setFp :: Int -> Computation ()
setFp fp = get >>= \vm -> put vm { _fp = fp }

setHalt :: Bool -> Computation ()
setHalt halt = get >>= \vm -> put vm { _halt = halt }

pop :: Int -> Computation [Int]
pop count = do
  vm <- get
  let stack = _stack vm
  put vm { _stack = S.drop count stack }
  return $ toList $ S.take count stack

push :: [Int] -> Computation ()
push = pushS . S.fromList

pushS :: S.Seq Int -> Computation ()
pushS numbers = get >>= \vm -> put vm { _stack = numbers <> _stack vm }

forward :: Int -> Computation ()
forward offset = get >>= \vm -> put vm { _pc = _pc vm + offset }