{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Nes.Memory.Unsafe () where

import Control.Monad.IO.Class
import Foreign
import GHC.ForeignPtr (unsafeWithForeignPtr)
import GHC.Storable
import Nes.Memory

-- | Highly unsafe instance that uses pointers directly.
--
-- No bound checks are done.
instance (MonadIO m) => MemoryInterface (Ptr a) m where
    readByte :: Addr -> Ptr a -> m Byte
readByte Addr
idx Ptr a
ptr = Word8 -> Byte
Byte (Word8 -> Byte) -> m Word8 -> m Byte
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word8 -> m Word8
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Word8 -> Int -> IO Word8
readWord8OffPtr (Ptr a -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ Addr -> Word16
unAddr Addr
idx))
    readAddr :: Addr -> Ptr a -> m Addr
readAddr Addr
idx Ptr a
ptr = IO Addr -> m Addr
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Addr -> m Addr) -> IO Addr -> m Addr
forall a b. (a -> b) -> a -> b
$ do
        let castedPtr :: Ptr Word8
castedPtr = Ptr a -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr
            intIdx :: Int
intIdx = Addr -> Int
addrToInt Addr
idx
        Byte
low <- Word8 -> Byte
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Byte) -> IO Word8 -> IO Byte
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
readWord8OffPtr Ptr Word8
castedPtr Int
intIdx
        Byte
high <- Word8 -> Byte
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Byte) -> IO Word8 -> IO Byte
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word8
readWord8OffPtr Ptr Word8
castedPtr (Int
intIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        Addr -> IO Addr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Addr -> IO Addr) -> Addr -> IO Addr
forall a b. (a -> b) -> a -> b
$ Byte -> Byte -> Addr
bytesToAddr Byte
low Byte
high
    writeByte :: Byte -> Addr -> Ptr a -> m ()
writeByte Byte
byte Addr
idx Ptr a
ptr = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr (Ptr a -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) (Addr -> Int
addrToInt Addr
idx) (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Byte -> Word8
unByte Byte
byte

    writeAddr :: Addr -> Addr -> Ptr a -> m ()
writeAddr Addr
addr Addr
idx Ptr a
ptr = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        let intIdx :: Int
intIdx = Addr -> Int
addrToInt Addr
idx
        Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr (Ptr a -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) Int
intIdx (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word8) -> Word16 -> Word8
forall a b. (a -> b) -> a -> b
$ Addr -> Word16
unAddr Addr
addr)
        Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr (Ptr a -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) (Int
intIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word8) -> Word16 -> Word8
forall a b. (a -> b) -> a -> b
$ Addr -> Word16
unAddr (Addr -> Word16) -> Addr -> Word16
forall a b. (a -> b) -> a -> b
$ Addr -> Int -> Addr
forall a. Bits a => a -> Int -> a
shiftR Addr
addr Int
8)

instance (MonadIO m) => MemoryInterface (ForeignPtr a) m where
    {-# INLINE readByte #-}
    readByte :: Addr -> ForeignPtr a -> m Byte
readByte Addr
idx ForeignPtr a
fptr = IO Byte -> m Byte
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Byte -> m Byte) -> IO Byte -> m Byte
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO Byte) -> IO Byte
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fptr (Addr -> Ptr a -> IO Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte Addr
idx)

    {-# INLINE readAddr #-}
    readAddr :: Addr -> ForeignPtr a -> m Addr
readAddr Addr
idx ForeignPtr a
fptr = IO Addr -> m Addr
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Addr -> m Addr) -> IO Addr -> m Addr
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO Addr) -> IO Addr
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fptr (Addr -> Ptr a -> IO Addr
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Addr
readAddr Addr
idx)

    {-# INLINE writeByte #-}
    writeByte :: Byte -> Addr -> ForeignPtr a -> m ()
writeByte Byte
byte Addr
idx ForeignPtr a
fptr = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fptr (Byte -> Addr -> Ptr a -> IO ()
forall a (m :: * -> *).
MemoryInterface a m =>
Byte -> Addr -> a -> m ()
writeByte Byte
byte Addr
idx)

    {-# INLINE writeAddr #-}
    writeAddr :: Addr -> Addr -> ForeignPtr a -> m ()
writeAddr Addr
addr Addr
idx ForeignPtr a
fptr = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fptr (Addr -> Addr -> Ptr a -> IO ()
forall a (m :: * -> *).
MemoryInterface a m =>
Addr -> Addr -> a -> m ()
writeAddr Addr
addr Addr
idx)