{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TemplateHaskell            #-}

module Hexploration.Emulator.Internal where

import Hexploration.Byte

import Control.Applicative
import Control.Lens
import Control.Monad.Reader
import Control.Monad.Trans.Either
import Data.Binary
import Data.Bits
import Data.Word.Odd
import Data.Vector.Binary ()
import Data.Vector.Unboxed (Vector)
import Data.Vector.Unboxed.Mutable (IOVector)

import qualified Data.Vector.Unboxed.Mutable as Vector
import qualified Data.Vector.Generic as Generic.Vector
import qualified Data.Vector.Unboxed as Unboxed.Vector

-- | An address has 64 bits.
type Address = BytesX4

-- | Registers are indexed by the number of their least significant byte (from 0 to 255) 
-- and their size (1 Byte, 2 Bytes, 4 Bytes, 8 Bytes or 16 Bytes).
data RegisterIndex   = RegisterIndex
                     { registerNumber :: Int
                     , registerSize   :: Int }
type RegisterContent = Vector Byte

-- | A register index for registers with special size (from 1 Byte to 16 Bytes).
newtype SpecialRegisterIndex = SpecialRegisterIndex { specialRegisterIndex :: RegisterIndex }

type Registers = IOVector Byte
type Memory    = IOVector Byte

-- | The Processor consists of the registers and the random access memory.
data Processor = Processor
               { _registers :: Registers
               , _memory    :: Memory    }
makeLenses ''Processor

-- | There are various errors that can happen during the operation of the Processor.
data OperationError = UnknownInstructionCode
                    | UnsupportedInstruction
                    | NonExistentMemory
                    | NonExistentRegister
                    | WrongRegisterSize

-- | The Operation Monad describes the operation of the Processor.
newtype Operation a = Operation { operation :: EitherT OperationError (ReaderT Processor IO) a } deriving (Functor, Applicative, Monad)

-- | Throw an 'OperationError' in the 'Operation' monad.
throwError :: OperationError -> Operation a
throwError = Operation . left

-- | Create a well-formed 'RegisterIndex'.
-- Return 'Just' the 'RegisterIndex' or 'Nothing' if it cannot be generated
-- (not even by possibly adjusting the register number to the register size).
createRegisterIndex :: Word8 -> Word4 -> Either OperationError RegisterIndex
createRegisterIndex n s
  | s' `elem` [1, 2, 4, 8, 16] = Right $ RegisterIndex (n' - n' `rem` s') s'
  | otherwise                  = Left WrongRegisterSize
  where s' = fromIntegral s + 1
        n' = fromIntegral n

-- | Check whether the given index is well-formed.
-- Return 'True' if it is or 'False' otherwise.
checkRegisterIndex   :: RegisterIndex -> Bool
checkRegisterIndex i = registerSize i `elem` [1, 2, 4, 8, 16]
                     && registerNumber i >= 0 && registerNumber i < 256
                     && registerNumber i `rem` registerSize i == 0

-- | Parse a 'RegisterIndex' in the 'Operation' monad.
parseRegisterIndex :: Word2 -> Word8 -> Operation RegisterIndex
parseRegisterIndex size number = Operation $ hoistEither $ createRegisterIndex number' size' where
  number' | size == 3  = shift number 1
          | otherwise = number
  size' | size == 3 && number >= 0x80 = 0xF
        | otherwise                = (2 ^ size) - 1

-- | Create a well-formed 'SpecialRegisterIndex'.
-- Return 'Just' the 'SpecialRegisterIndex' or 'Nothing' if it cannot be generated with the given arguments.
createSpecialRegisterIndex :: Word8 -> Word4 -> Either OperationError SpecialRegisterIndex
createSpecialRegisterIndex n s
  | s' + n' >= 256          = Left NonExistentRegister
  | s' `notElem` [1 .. 16] = Left WrongRegisterSize
  | otherwise              = Right $ SpecialRegisterIndex $ RegisterIndex n' s'
  where n' = fromIntegral n
        s' = fromIntegral s + 1

-- | Check whether the given special index is well-formed.
-- Return 'True' if it is or 'False' otherwise.
checkSpecialRegisterIndex   :: SpecialRegisterIndex -> Bool
checkSpecialRegisterIndex i = registerNumber i' + registerSize i' < 256 && registerSize i' `elem` [1 .. 16]
  where i' = specialRegisterIndex i

-- | Parse a 'SpecialRegisterIndex' in the 'Operation' monad.
parseSpecialRegisterIndex :: Word4 -> Word8 -> Operation SpecialRegisterIndex
parseSpecialRegisterIndex size number = Operation $ hoistEither $ createSpecialRegisterIndex number size

-- | The index of the instruction pointer.
-- This index can be used, but checking whether it is well-formed will return false.
instructionPointer :: RegisterIndex
instructionPointer = RegisterIndex 256 4

-- | Get the size of the useable memory.
memorySize :: Integral a => Operation a
memorySize = fromIntegral <$> Operation (view $ memory . to Vector.length)

-- | An isomorphism between the content of a register and an 'Integral' of the right size.
#if MIN_VERSION_base(4,7,0)
#define BITS FiniteBits
#define bitSIZE finiteBitSize
#else
#define BITS Bits
#define bitSIZE bitSize
#endif
registerContent :: (BITS a, Integral a) => Iso' a RegisterContent
registerContent = iso toRegisterContent fromRegisterContent
  where fromRegisterContent = flip Generic.Vector.ifoldl' 0 $ \ x i y  -> x + shiftL (fromIntegral y) (16 * i)
        toRegisterContent x = Generic.Vector.generate (size x) $ \ i -> fromIntegral $ shiftR x (16 * i) .&. 0xFFFF
        size x = case bitSIZE x `divMod` 16 of
                      (n, 0) -> n
                      (n, _) -> n + 1

-- | Run the processor operation on the given memory.
-- All registers will be filled with zeros and the instruction pointer points to 0.
runProcessor :: Memory -> Operation a -> IO (Either OperationError a)
runProcessor m o = do
  rs <- Vector.replicate 260 0
  runReaderT (runEitherT $ operation o) $ Processor rs m

-- | Get an 'Operation' which reads the specified register.
--
-- Warning: The 'RegisterIndex' must be well-formed.
readRegister   :: RegisterIndex -> Operation RegisterContent
readRegister i = Operation $ view registers >>= lift . lift . Generic.Vector.freeze . Vector.slice (registerNumber i) (registerSize i)

-- | Get an 'Operation' which writes the 'RegisterContent' to the specified register.
--
-- Warning: The 'RegisterIndex' must be well-formed and the 'RegisterContent' must have the specified size.
writeRegister     :: RegisterIndex -> RegisterContent -> Operation ()
writeRegister i x = Operation $ view registers >>= lift . lift . flip Generic.Vector.copy x . Vector.slice (registerNumber i) (registerSize i)

-- | Get an 'Operation' which modifies the specified register with the specified function.
--
-- Warning: The 'RegisterIndex' must be well-formed and the function must work on the specified size.
modifyRegister     :: RegisterIndex -> (RegisterContent -> RegisterContent) -> Operation ()
modifyRegister i f = writeRegister i =<< f <$> readRegister i

-- | Get an 'Operation' which loads the content at the specified address into the specified register.
--
-- Warning: The 'SpecialRegisterIndex' must be well-formed and the address must be in the bounds of the memory.
loadFromMemory     :: Address -> SpecialRegisterIndex -> Operation ()
loadFromMemory a i = Operation $ do
  register <- Vector.slice (registerNumber i') (registerSize i') <$> view registers
  lift . lift . Vector.unsafeCopy register =<< Vector.slice (fromIntegral a) (registerSize i') <$> view memory
  where i' = specialRegisterIndex i

-- | Get an 'Operation' which stores the content of the specified register at the specified address.
--
-- Warning: The 'SpecialRegisterIndex' must be well-formed and the address must be in the bounds of the memory.
storeInMemory     :: Address -> SpecialRegisterIndex -> Operation ()
storeInMemory a i = Operation $ do
  register <- Vector.slice (registerNumber i') (registerSize i') <$> view registers
  lift . lift . flip Vector.unsafeCopy register =<< Vector.slice (fromIntegral a) (registerSize i') <$> view memory
  where i' = specialRegisterIndex i

-- | Get an 'Operation' which reads the specified file to the addresses starting at the specified address.
--
-- Warning: The 'FilePath' must be well-formed and the memory must be large enough.
readMemoryFile        :: FilePath -> Address -> Operation ()
readMemoryFile path a = Operation $ do
  content <- lift . lift $ decodeFile path
  lift . lift . flip Generic.Vector.unsafeCopy content =<< Vector.slice (fromIntegral a) (Unboxed.Vector.length content) <$> view memory

-- | Get an 'Operation' which writes the specified number of bytes
-- from the memory starting at the specified address to the specified file.
--
-- Warning: The 'FilePath' must be well-formed and there must be enough memory to write.
writeMemoryFile          :: FilePath -> Address -> Int -> Operation ()
writeMemoryFile path a n = Operation $ do
  content <- lift . lift . Generic.Vector.freeze . Vector.slice (fromIntegral a) n =<< view memory
  lift . lift $ encodeFile path (content :: Vector Byte)

-- | Get the next byte of processor instruction code.
-- This operation also increments the instruction pointer by one.
instructionCode :: Operation Byte
instructionCode = Operation $ do
  address <- view (from registerContent) <$> operation (readRegister instructionPointer)
  operation $ writeRegister instructionPointer $ view registerContent $ address + 1
  view memory >>= lift . lift . flip Vector.read address
