module Nes.Bus.Monad (Bus (..), runBus, tick, liftPPU, liftAPU, liftController) where

import Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import Data.Functor (($>))
import Data.Ix
import Foreign
import Nes.APU.BusInterface
import Nes.APU.Monad
import Nes.APU.State
import qualified Nes.APU.Tick as APU
import Nes.Bus.Constants
import Nes.Bus.State
import Nes.Controller
import Nes.FlagRegister (clearFlag)
import Nes.Internal.MonadState
import Nes.Interrupt (InterruptStatus)
import Nes.Memory
import Nes.PPU.Constants (oamDataSize)
import Nes.PPU.Monad hiding (tick)
import qualified Nes.PPU.Monad as PPUM
import Nes.PPU.State hiding (cycles)
import Nes.Rom

newtype Bus r a = MkBus {forall r a. Bus r a -> BusState -> (BusState -> a -> IO r) -> IO r
unBus :: BusState -> (BusState -> a -> IO r) -> IO r} deriving ((forall a b. (a -> b) -> Bus r a -> Bus r b)
-> (forall a b. a -> Bus r b -> Bus r a) -> Functor (Bus r)
forall a b. a -> Bus r b -> Bus r a
forall a b. (a -> b) -> Bus r a -> Bus r b
forall r a b. a -> Bus r b -> Bus r a
forall r a b. (a -> b) -> Bus r a -> Bus r b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall r a b. (a -> b) -> Bus r a -> Bus r b
fmap :: forall a b. (a -> b) -> Bus r a -> Bus r b
$c<$ :: forall r a b. a -> Bus r b -> Bus r a
<$ :: forall a b. a -> Bus r b -> Bus r a
Functor)

instance Applicative (Bus r) where
    {-# INLINE pure #-}
    pure :: forall a. a -> Bus r a
pure a
a = (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a)
-> (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> a -> IO r
cont -> BusState -> a -> IO r
cont BusState
bus a
a

    {-# INLINE liftA2 #-}
    liftA2 :: forall a b c. (a -> b -> c) -> Bus r a -> Bus r b -> Bus r c
liftA2 a -> b -> c
f (MkBus BusState -> (BusState -> a -> IO r) -> IO r
a) (MkBus BusState -> (BusState -> b -> IO r) -> IO r
b) = (BusState -> (BusState -> c -> IO r) -> IO r) -> Bus r c
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> c -> IO r) -> IO r) -> Bus r c)
-> (BusState -> (BusState -> c -> IO r) -> IO r) -> Bus r c
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> c -> IO r
cont ->
        BusState -> (BusState -> a -> IO r) -> IO r
a BusState
bus ((BusState -> a -> IO r) -> IO r)
-> (BusState -> a -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \BusState
bus' a
a' -> BusState -> (BusState -> b -> IO r) -> IO r
b BusState
bus' ((BusState -> b -> IO r) -> IO r)
-> (BusState -> b -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \BusState
bus'' b
b' -> BusState -> c -> IO r
cont BusState
bus'' (a -> b -> c
f a
a' b
b')

instance Monad (Bus r) where
    {-# INLINE (>>=) #-}
    (MkBus BusState -> (BusState -> a -> IO r) -> IO r
a) >>= :: forall a b. Bus r a -> (a -> Bus r b) -> Bus r b
>>= a -> Bus r b
next = (BusState -> (BusState -> b -> IO r) -> IO r) -> Bus r b
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> b -> IO r) -> IO r) -> Bus r b)
-> (BusState -> (BusState -> b -> IO r) -> IO r) -> Bus r b
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> b -> IO r
cont ->
        BusState -> (BusState -> a -> IO r) -> IO r
a BusState
bus ((BusState -> a -> IO r) -> IO r)
-> (BusState -> a -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \BusState
bus' a
a' -> Bus r b -> BusState -> (BusState -> b -> IO r) -> IO r
forall r a. Bus r a -> BusState -> (BusState -> a -> IO r) -> IO r
unBus (a -> Bus r b
next a
a') BusState
bus' ((BusState -> b -> IO r) -> IO r)
-> (BusState -> b -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \BusState
bus'' b
res -> BusState -> b -> IO r
cont BusState
bus'' b
res

instance MonadIO (Bus r) where
    {-# INLINE liftIO #-}
    liftIO :: forall a. IO a -> Bus r a
liftIO IO a
io = (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a)
-> (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> a -> IO r
cont -> IO a
io IO a -> (a -> IO r) -> IO r
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BusState -> a -> IO r
cont BusState
bus

instance MonadFail (Bus r) where
    {-# INLINE fail #-}
    fail :: forall a. String -> Bus r a
fail = IO a -> Bus r a
forall a. IO a -> Bus r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Bus r a) -> (String -> IO a) -> String -> Bus r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

instance MonadState BusState (Bus r) where
    {-# INLINE set #-}
    set :: BusState -> Bus r ()
set BusState
bus' = (BusState -> (BusState -> () -> IO r) -> IO r) -> Bus r ()
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> () -> IO r) -> IO r) -> Bus r ())
-> (BusState -> (BusState -> () -> IO r) -> IO r) -> Bus r ()
forall a b. (a -> b) -> a -> b
$ \BusState
_ BusState -> () -> IO r
cont -> BusState -> () -> IO r
cont BusState
bus' ()
    {-# INLINE get #-}
    get :: Bus r BusState
get = (BusState -> (BusState -> BusState -> IO r) -> IO r)
-> Bus r BusState
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> BusState -> IO r) -> IO r)
 -> Bus r BusState)
-> (BusState -> (BusState -> BusState -> IO r) -> IO r)
-> Bus r BusState
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> BusState -> IO r
cont -> BusState -> BusState -> IO r
cont BusState
bus BusState
bus

{-# INLINE runBus #-}
runBus :: BusState -> Bus (a, BusState) a -> IO (a, BusState)
runBus :: forall a. BusState -> Bus (a, BusState) a -> IO (a, BusState)
runBus BusState
bus Bus (a, BusState) a
f = Bus (a, BusState) a
-> BusState
-> (BusState -> a -> IO (a, BusState))
-> IO (a, BusState)
forall r a. Bus r a -> BusState -> (BusState -> a -> IO r) -> IO r
unBus Bus (a, BusState) a
f BusState
bus (\BusState
bus' a
a -> (a, BusState) -> IO (a, BusState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, BusState
bus'))

{-# INLINE liftPPU #-}
liftPPU :: PPU (a, PPUState) a -> Bus r a
liftPPU :: forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU PPU (a, PPUState) a
f = (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a)
-> (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> a -> IO r
cont -> do
    (a
res, PPUState
ppuSt) <- PPUState
-> PPUPointers -> Rom -> PPU (a, PPUState) a -> IO (a, PPUState)
forall a.
PPUState
-> PPUPointers -> Rom -> PPU (a, PPUState) a -> IO (a, PPUState)
runPPU (BusState -> PPUState
_ppuState BusState
bus) (BusState -> PPUPointers
_ppuPointers BusState
bus) (BusState -> Rom
_cartridge BusState
bus) PPU (a, PPUState) a
f
    BusState -> a -> IO r
cont (BusState
bus{_ppuState = ppuSt}) a
res

{-# INLINE liftAPU #-}
liftAPU :: APU (a, APUState, InterruptStatus) a -> Bus r a
liftAPU :: forall a r. APU (a, APUState, InterruptStatus) a -> Bus r a
liftAPU APU (a, APUState, InterruptStatus) a
f = (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a)
-> (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> a -> IO r
cont -> do
    (!a
res, !APUState
apuSt', !InterruptStatus
cpuInterr') <- APUState
-> InterruptStatus
-> APU (a, APUState, InterruptStatus) a
-> IO (a, APUState, InterruptStatus)
forall a.
APUState
-> InterruptStatus
-> APU (a, APUState, InterruptStatus) a
-> IO (a, APUState, InterruptStatus)
runAPU (BusState -> APUState
_apuState BusState
bus) (BusState -> InterruptStatus
_cpuInterrupt BusState
bus) APU (a, APUState, InterruptStatus) a
f
    BusState -> a -> IO r
cont (BusState
bus{_apuState = apuSt', _cpuInterrupt = cpuInterr'}) a
res

{-# INLINE liftController #-}
liftController :: Controller (a, ControllerState) a -> Bus r a
liftController :: forall a r. Controller (a, ControllerState) a -> Bus r a
liftController Controller (a, ControllerState) a
f = (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a)
-> (BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> a -> IO r
cont ->
    let
        (a
res, ControllerState
controller') = Controller (a, ControllerState) a
-> ControllerState -> (a, ControllerState)
forall a.
Controller (a, ControllerState) a
-> ControllerState -> (a, ControllerState)
runController Controller (a, ControllerState) a
f (BusState -> ControllerState
_controller BusState
bus)
     in
        BusState -> a -> IO r
cont (BusState
bus{_controller = controller'}) a
res

tick :: Int -> Bus r ()
tick :: forall r. Int -> Bus r ()
tick Int
n = (BusState -> (BusState -> () -> IO r) -> IO r) -> Bus r ()
forall r a.
(BusState -> (BusState -> a -> IO r) -> IO r) -> Bus r a
MkBus ((BusState -> (BusState -> () -> IO r) -> IO r) -> Bus r ())
-> (BusState -> (BusState -> () -> IO r) -> IO r) -> Bus r ()
forall a b. (a -> b) -> a -> b
$ \BusState
bus BusState -> () -> IO r
cont -> do
    let unsleptCycles_ :: Int
unsleptCycles_ = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BusState -> Int
_unsleptCycles BusState
bus
    (Double
newLastSleepTime, Int
newUnsleptCycles) <-
        BusState -> Double -> Int -> IO (Double, Int)
_cycleCallback BusState
bus (BusState -> Double
_lastSleepTime BusState
bus) Int
unsleptCycles_
    (Bool
isNewFrame, PPUState
ppuSt) <- PPUState
-> PPUPointers
-> Rom
-> PPU (Bool, PPUState) Bool
-> IO (Bool, PPUState)
forall a.
PPUState
-> PPUPointers -> Rom -> PPU (a, PPUState) a -> IO (a, PPUState)
runPPU (BusState -> PPUState
_ppuState BusState
bus) (BusState -> PPUPointers
_ppuPointers BusState
bus) (BusState -> Rom
_cartridge BusState
bus) (PPU (Bool, PPUState) Bool -> IO (Bool, PPUState))
-> PPU (Bool, PPUState) Bool -> IO (Bool, PPUState)
forall a b. (a -> b) -> a -> b
$ do
        Bool
before <- Getting Bool PPUState Bool -> PPU (Bool, PPUState) Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool PPUState Bool
Lens' PPUState Bool
nmiInterrupt
        Bool
_ <- Int -> PPU (Bool, PPUState) Bool
forall r. Int -> PPU r Bool
PPUM.tick (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3)
        Bool
after <- Getting Bool PPUState Bool -> PPU (Bool, PPUState) Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool PPUState Bool
Lens' PPUState Bool
nmiInterrupt
        Bool -> PPU (Bool, PPUState) Bool
forall a. a -> PPU (Bool, PPUState) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
before Bool -> Bool -> Bool
&& Bool
after)
    ((), !APUState
apuSt, !InterruptStatus
interr) <- APUState
-> InterruptStatus
-> APU ((), APUState, InterruptStatus) ()
-> IO ((), APUState, InterruptStatus)
forall a.
APUState
-> InterruptStatus
-> APU (a, APUState, InterruptStatus) a
-> IO (a, APUState, InterruptStatus)
runAPU (BusState -> APUState
_apuState BusState
bus) (BusState -> InterruptStatus
_cpuInterrupt BusState
bus) (APU ((), APUState, InterruptStatus) ()
 -> IO ((), APUState, InterruptStatus))
-> APU ((), APUState, InterruptStatus) ()
-> IO ((), APUState, InterruptStatus)
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> APU ((), APUState, InterruptStatus) ()
forall r. Bool -> Int -> APU r ()
APU.tick (Integer -> Bool
forall a. Integral a => a -> Bool
odd (BusState -> Integer
Nes.Bus.State._cycles BusState
bus)) Int
n
    let bus' :: BusState
bus' =
            BusState
bus
                { _unsleptCycles = newUnsleptCycles
                , _ppuState = ppuSt
                , _apuState = apuSt
                , _cycles = fromIntegral n + Nes.Bus.State._cycles bus
                , _lastSleepTime = newLastSleepTime
                , _cpuInterrupt = interr
                }
    if Bool
isNewFrame
        then do
            BusState -> BusState -> IO ()
_onNewFrame BusState
bus' BusState
bus'
            ControllerState
controller' <- IO ControllerState -> IO ControllerState
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (BusState -> ControllerState -> IO ControllerState
_pollControls BusState
bus' (ControllerState -> IO ControllerState)
-> ControllerState -> IO ControllerState
forall a b. (a -> b) -> a -> b
$ BusState -> ControllerState
_controller BusState
bus')
            BusState -> () -> IO r
cont BusState
bus'{_controller = controller'} ()
        else
            BusState -> () -> IO r
cont BusState
bus' ()

data BusReadOutput = OpenBus | DataBus Byte | Internal Byte

instance MemoryInterface () (Bus r) where
    readByte :: Addr -> () -> Bus r Byte
readByte Addr
idx () =
        Bus r BusReadOutput
go Bus r BusReadOutput -> (BusReadOutput -> Bus r Byte) -> Bus r Byte
forall a b. Bus r a -> (a -> Bus r b) -> Bus r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            DataBus Byte
byte -> ((Byte -> Identity Byte) -> BusState -> Identity BusState
Lens' BusState Byte
dataBus ((Byte -> Identity Byte) -> BusState -> Identity BusState)
-> Byte -> Bus r ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> a -> m ()
.= Byte
byte) Bus r () -> Byte -> Bus r Byte
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Byte
byte
            BusReadOutput
OpenBus -> Getting Byte BusState Byte -> Bus r Byte
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Byte BusState Byte
Lens' BusState Byte
dataBus
            Internal Byte
byte -> Byte -> Bus r Byte
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return Byte
byte
      where
        go :: Bus r BusReadOutput
go
            | (Addr, Addr) -> Addr -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Addr, Addr)
ramRange Addr
idx = do
                let mirroredDownAddr :: Addr
mirroredDownAddr = Addr
idx Addr -> Addr -> Addr
forall a. Bits a => a -> a -> a
.&. Addr
0b11111111111 -- 11 bits
                (Byte -> BusReadOutput) -> Bus r Byte -> Bus r BusReadOutput
forall a b. (a -> b) -> Bus r a -> Bus r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Byte -> BusReadOutput
DataBus (Bus r Byte -> Bus r BusReadOutput)
-> (MemoryPointer -> Bus r Byte)
-> MemoryPointer
-> Bus r BusReadOutput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Byte -> Bus r Byte
forall a. IO a -> Bus r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Byte -> Bus r Byte)
-> (MemoryPointer -> IO Byte) -> MemoryPointer -> Bus r Byte
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> MemoryPointer -> IO Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte Addr
mirroredDownAddr (MemoryPointer -> Bus r BusReadOutput)
-> Bus r MemoryPointer -> Bus r BusReadOutput
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Getting MemoryPointer BusState MemoryPointer -> Bus r MemoryPointer
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting MemoryPointer BusState MemoryPointer
Lens' BusState MemoryPointer
cpuVram
            | (Addr, Addr) -> Addr -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Addr, Addr)
ppuRegisters Addr
idx = do
                let mirroredIdx :: Addr
mirroredIdx = Word16 -> Addr
Addr (Word16 -> Addr) -> (Int -> Word16) -> Int -> Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Addr) -> Int -> Addr
forall a b. (a -> b) -> a -> b
$ Addr -> Int
addrToInt (Addr
idx Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
- (Addr, Addr) -> Addr
forall a b. (a, b) -> a
fst (Addr, Addr)
ppuRegisters) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8
                    onInvalidRead :: Bus r BusReadOutput
onInvalidRead = Byte -> BusReadOutput
DataBus (Byte -> BusReadOutput) -> Bus r Byte -> Bus r BusReadOutput
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting PPUState BusState PPUState
-> (PPUState -> Byte) -> Bus r Byte
forall s (m :: * -> *) a r.
MonadState s m =>
Getting a s a -> (a -> r) -> m r
uses Getting PPUState BusState PPUState
Lens' BusState PPUState
ppuState PPUState -> Byte
_ioBus
                case Addr
mirroredIdx of
                    Addr
0 ->
                        if Addr
idx Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
0x2000
                            then Bus r BusReadOutput
onInvalidRead
                            else
                                let
                                    addr1 :: Addr
addr1 = Addr
idx Addr -> Addr -> Addr
forall a. Bits a => a -> a -> a
.&. Addr
0b0010000000000111
                                 in
                                    Byte -> BusReadOutput
DataBus (Byte -> BusReadOutput) -> Bus r Byte -> Bus r BusReadOutput
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr -> () -> Bus r Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte Addr
addr1 ()
                    Addr
1 -> Bus r BusReadOutput
onInvalidRead
                    Addr
2 -> PPU (BusReadOutput, PPUState) BusReadOutput -> Bus r BusReadOutput
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU (BusReadOutput, PPUState) BusReadOutput
 -> Bus r BusReadOutput)
-> PPU (BusReadOutput, PPUState) BusReadOutput
-> Bus r BusReadOutput
forall a b. (a -> b) -> a -> b
$ do
                        Byte
st <- PPU (BusReadOutput, PPUState) Byte
forall r. PPU r Byte
readStatus
                        -- https://www.nesdev.org/wiki/PPU_registers#PPUSTATUS_-_Rendering_events_($2002_read)
                        (StatusRegister -> Identity StatusRegister)
-> PPUState -> Identity PPUState
Lens' PPUState StatusRegister
statusRegister ((StatusRegister -> Identity StatusRegister)
 -> PPUState -> Identity PPUState)
-> (StatusRegister -> StatusRegister)
-> PPU (BusReadOutput, PPUState) ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> (a -> a) -> m ()
%= Flag StatusRegister -> StatusRegister -> StatusRegister
forall a. FlagRegister a => Flag a -> a -> a
clearFlag Flag StatusRegister
StatusRegisterFlag
VBlankStarted
                        Byte
oldIoBusState <- Getting Byte PPUState Byte -> PPU (BusReadOutput, PPUState) Byte
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Byte PPUState Byte
Lens' PPUState Byte
ioBus
                        let newIoBus :: Byte
newIoBus = (Byte
st Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.&. Byte
0b11100000) Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.|. (Byte
oldIoBusState Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.&. Byte
0b11111)
                        (Byte -> Identity Byte) -> PPUState -> Identity PPUState
Lens' PPUState Byte
ioBus ((Byte -> Identity Byte) -> PPUState -> Identity PPUState)
-> Byte -> PPU (BusReadOutput, PPUState) ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> a -> m ()
.= Byte
newIoBus
                        BusReadOutput -> PPU (BusReadOutput, PPUState) BusReadOutput
forall a. a -> PPU (BusReadOutput, PPUState) a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusReadOutput -> PPU (BusReadOutput, PPUState) BusReadOutput)
-> BusReadOutput -> PPU (BusReadOutput, PPUState) BusReadOutput
forall a b. (a -> b) -> a -> b
$ Byte -> BusReadOutput
DataBus Byte
st
                    Addr
3 -> Bus r BusReadOutput
onInvalidRead
                    Addr
4 -> (Byte -> BusReadOutput) -> Bus r Byte -> Bus r BusReadOutput
forall a b. (a -> b) -> Bus r a -> Bus r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Byte -> BusReadOutput
DataBus (Bus r Byte -> Bus r BusReadOutput)
-> Bus r Byte -> Bus r BusReadOutput
forall a b. (a -> b) -> a -> b
$ PPU (Byte, PPUState) Byte -> Bus r Byte
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU (Byte, PPUState) Byte -> Bus r Byte)
-> PPU (Byte, PPUState) Byte -> Bus r Byte
forall a b. (a -> b) -> a -> b
$ do
                        Byte
res <- PPU (Byte, PPUState) Byte
forall r. PPU r Byte
readOamData
                        (Byte -> Identity Byte) -> PPUState -> Identity PPUState
Lens' PPUState Byte
ioBus ((Byte -> Identity Byte) -> PPUState -> Identity PPUState)
-> Byte -> PPU (Byte, PPUState) ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> a -> m ()
.= Byte
res
                        Byte -> PPU (Byte, PPUState) Byte
forall a. a -> PPU (Byte, PPUState) a
forall (m :: * -> *) a. Monad m => a -> m a
return Byte
res
                    Addr
5 -> Bus r BusReadOutput
onInvalidRead
                    Addr
6 -> Bus r BusReadOutput
onInvalidRead
                    Addr
7 -> (Byte -> BusReadOutput) -> Bus r Byte -> Bus r BusReadOutput
forall a b. (a -> b) -> Bus r a -> Bus r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Byte -> BusReadOutput
DataBus (Bus r Byte -> Bus r BusReadOutput)
-> Bus r Byte -> Bus r BusReadOutput
forall a b. (a -> b) -> a -> b
$ PPU (Byte, PPUState) Byte -> Bus r Byte
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU (Byte, PPUState) Byte -> Bus r Byte)
-> PPU (Byte, PPUState) Byte -> Bus r Byte
forall a b. (a -> b) -> a -> b
$ do
                        Byte
res <- PPU (Byte, PPUState) Byte
forall r. PPU r Byte
readData
                        (Byte -> Identity Byte) -> PPUState -> Identity PPUState
Lens' PPUState Byte
ioBus ((Byte -> Identity Byte) -> PPUState -> Identity PPUState)
-> Byte -> PPU (Byte, PPUState) ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> a -> m ()
.= Byte
res
                        Byte -> PPU (Byte, PPUState) Byte
forall a. a -> PPU (Byte, PPUState) a
forall (m :: * -> *) a. Monad m => a -> m a
return Byte
res
                    Addr
_ -> String -> Bus r BusReadOutput
forall a. HasCallStack => String -> a
error String
"Cannot happen"
            | (Addr, Addr) -> Addr -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Addr, Addr)
prgRomRange Addr
idx = do
                Rom
rom <- Getting Rom BusState Rom -> Bus r Rom
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Rom BusState Rom
Lens' BusState Rom
cartridge
                Byte -> BusReadOutput
DataBus (Byte -> BusReadOutput) -> Bus r Byte -> Bus r BusReadOutput
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr
-> Rom -> (Addr -> ForeignPtr Word8 -> Bus r Byte) -> Bus r Byte
forall (m :: * -> *) a.
MonadFail m =>
Addr -> Rom -> (Addr -> ForeignPtr Word8 -> m a) -> m a
readPrgRomAddr (Addr
idx Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
- (Addr, Addr) -> Addr
forall a b. (a, b) -> a
fst (Addr, Addr)
prgRomRange) Rom
rom Addr -> ForeignPtr Word8 -> Bus r Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte
            | Addr
idx Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
0x4014 = BusReadOutput -> Bus r BusReadOutput
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusReadOutput -> Bus r BusReadOutput)
-> BusReadOutput -> Bus r BusReadOutput
forall a b. (a -> b) -> a -> b
$ Byte -> BusReadOutput
DataBus Byte
0
            | Addr
idx Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
0x4016 = do
                Byte
res <- Controller (Byte, ControllerState) Byte -> Bus r Byte
forall a r. Controller (a, ControllerState) a -> Bus r a
liftController Controller (Byte, ControllerState) Byte
forall r. Controller r Byte
readButtonStatus
                Byte
oldDataBusState <- Getting Byte BusState Byte -> Bus r Byte
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Byte BusState Byte
Lens' BusState Byte
dataBus
                let newDataBus :: Byte
newDataBus = (Byte
oldDataBusState Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.&. Byte
0b11100000) Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.|. (Byte
res Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.&. Byte
0b11111)
                BusReadOutput -> Bus r BusReadOutput
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusReadOutput -> Bus r BusReadOutput)
-> BusReadOutput -> Bus r BusReadOutput
forall a b. (a -> b) -> a -> b
$ Byte -> BusReadOutput
DataBus Byte
newDataBus
            | Addr
idx Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
0x4017 = do
                Byte
oldDataBusState <- Getting Byte BusState Byte -> Bus r Byte
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Byte BusState Byte
Lens' BusState Byte
dataBus
                BusReadOutput -> Bus r BusReadOutput
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusReadOutput -> Bus r BusReadOutput)
-> BusReadOutput -> Bus r BusReadOutput
forall a b. (a -> b) -> a -> b
$ Byte -> BusReadOutput
DataBus (Byte -> BusReadOutput) -> Byte -> BusReadOutput
forall a b. (a -> b) -> a -> b
$ Byte
oldDataBusState Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.&. Byte
0b11100000
            | (Addr
0x4000, Addr
0x4017) (Addr, Addr) -> Addr -> Bool
forall a. Ix a => (a, a) -> a -> Bool
`inRange` Addr
idx = do
                Maybe Byte
res <- APU (Maybe Byte, APUState, InterruptStatus) (Maybe Byte)
-> Bus r (Maybe Byte)
forall a r. APU (a, APUState, InterruptStatus) a -> Bus r a
liftAPU (APU (Maybe Byte, APUState, InterruptStatus) (Maybe Byte)
 -> Bus r (Maybe Byte))
-> APU (Maybe Byte, APUState, InterruptStatus) (Maybe Byte)
-> Bus r (Maybe Byte)
forall a b. (a -> b) -> a -> b
$ Addr -> APU (Maybe Byte, APUState, InterruptStatus) (Maybe Byte)
forall r. Addr -> APU r (Maybe Byte)
readFromAPU Addr
idx
                case Maybe Byte
res of
                    Maybe Byte
Nothing -> BusReadOutput -> Bus r BusReadOutput
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return BusReadOutput
OpenBus
                    Just Byte
b -> do
                        Byte
b' <- do
                            if Addr
idx Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
0x4015
                                then do
                                    Bool
bit5 <- Getting Byte BusState Byte -> (Byte -> Bool) -> Bus r Bool
forall s (m :: * -> *) a r.
MonadState s m =>
Getting a s a -> (a -> r) -> m r
uses Getting Byte BusState Byte
Lens' BusState Byte
dataBus (Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
5)
                                    Byte -> Bus r Byte
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return (Byte -> Bus r Byte) -> Byte -> Bus r Byte
forall a b. (a -> b) -> a -> b
$ if Bool
bit5 then Byte
b Byte -> Int -> Byte
forall a. Bits a => a -> Int -> a
`setBit` Int
5 else Byte
b Byte -> Int -> Byte
forall a. Bits a => a -> Int -> a
`clearBit` Int
5
                                else Byte -> Bus r Byte
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return Byte
b
                        BusReadOutput -> Bus r BusReadOutput
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return (BusReadOutput -> Bus r BusReadOutput)
-> BusReadOutput -> Bus r BusReadOutput
forall a b. (a -> b) -> a -> b
$ Byte -> BusReadOutput
Internal Byte
b'
            | Bool
otherwise = BusReadOutput -> Bus r BusReadOutput
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return BusReadOutput
OpenBus

    writeByte :: Byte -> Addr -> () -> Bus r ()
writeByte Byte
byte Addr
idx () = Addr -> Bus r () -> Bus r ()
forall (m :: * -> *). MonadFail m => Addr -> m () -> m ()
guardWriteBound Addr
idx (Bus r () -> Bus r ()) -> Bus r () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ do
        (Byte -> Identity Byte) -> BusState -> Identity BusState
Lens' BusState Byte
dataBus ((Byte -> Identity Byte) -> BusState -> Identity BusState)
-> Byte -> Bus r ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> a -> m ()
.= Byte
byte
        Bus r ()
go
      where
        go :: Bus r ()
go
            | (Addr, Addr) -> Addr -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Addr, Addr)
ramRange Addr
idx =
                let
                    addr :: Addr
addr = Addr
idx Addr -> Addr -> Addr
forall a. Bits a => a -> a -> a
.&. Addr
0b11111111111
                 in
                    IO () -> Bus r ()
forall a. IO a -> Bus r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Bus r ())
-> (MemoryPointer -> IO ()) -> MemoryPointer -> Bus r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Byte -> Addr -> MemoryPointer -> IO ()
forall a (m :: * -> *).
MemoryInterface a m =>
Byte -> Addr -> a -> m ()
writeByte Byte
byte Addr
addr (MemoryPointer -> Bus r ()) -> Bus r MemoryPointer -> Bus r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Getting MemoryPointer BusState MemoryPointer -> Bus r MemoryPointer
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting MemoryPointer BusState MemoryPointer
Lens' BusState MemoryPointer
cpuVram
            | (Addr, Addr) -> Addr -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Addr, Addr)
ppuRegisters Addr
idx = do
                let mirroredIdx :: Addr
mirroredIdx = Word16 -> Addr
Addr (Word16 -> Addr) -> (Int -> Word16) -> Int -> Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Addr) -> Int -> Addr
forall a b. (a -> b) -> a -> b
$ Addr -> Int
addrToInt (Addr
idx Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
- (Addr, Addr) -> Addr
forall a b. (a, b) -> a
fst (Addr, Addr)
ppuRegisters) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8
                PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ (Byte -> Identity Byte) -> PPUState -> Identity PPUState
Lens' PPUState Byte
ioBus ((Byte -> Identity Byte) -> PPUState -> Identity PPUState)
-> Byte -> PPU ((), PPUState) ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> a -> m ()
.= Byte
byte
                case Addr
mirroredIdx of
                    Addr
0 ->
                        if Addr
idx Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
0x2000
                            then PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ Byte -> PPU ((), PPUState) ()
forall r. Byte -> PPU r ()
writeToControlRegister Byte
byte
                            else
                                let
                                    addr :: Addr
addr = Addr
idx Addr -> Addr -> Addr
forall a. Bits a => a -> a -> a
.&. Addr
0b0010000000000111
                                 in
                                    Byte -> Addr -> () -> Bus r ()
forall a (m :: * -> *).
MemoryInterface a m =>
Byte -> Addr -> a -> m ()
writeByte Byte
byte Addr
addr ()
                    Addr
1 -> PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ (MaskRegister -> Identity MaskRegister)
-> PPUState -> Identity PPUState
Lens' PPUState MaskRegister
maskRegister ((MaskRegister -> Identity MaskRegister)
 -> PPUState -> Identity PPUState)
-> MaskRegister -> PPU ((), PPUState) ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> a -> m ()
.= Byte -> MaskRegister
MkMR Byte
byte
                    Addr
2 -> () -> Bus r ()
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Addr
3 -> PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ (Byte -> Identity Byte) -> PPUState -> Identity PPUState
Lens' PPUState Byte
oamOffset ((Byte -> Identity Byte) -> PPUState -> Identity PPUState)
-> Byte -> PPU ((), PPUState) ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> a -> m ()
.= Byte
byte
                    Addr
4 -> PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ Byte -> PPU ((), PPUState) ()
forall r. Byte -> PPU r ()
writeOamData Byte
byte
                    Addr
5 -> PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ Byte -> PPU ((), PPUState) ()
forall r. Byte -> PPU r ()
setScrollRegister Byte
byte
                    Addr
6 -> PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ Byte -> PPU ((), PPUState) ()
forall r. Byte -> PPU r ()
writeToAddressRegister Byte
byte
                    Addr
7 -> PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ Byte -> PPU ((), PPUState) ()
forall r. Byte -> PPU r ()
writeData Byte
byte
                    Addr
_ -> String -> Bus r ()
forall a. HasCallStack => String -> a
error String
"Cannot happen"
            | (Addr, Addr) -> Addr -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Addr, Addr)
prgRomRange Addr
idx = IO () -> Bus r ()
forall a. IO a -> Bus r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Bus r ()) -> IO () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Cannot write to catridge"
            | Addr
idx Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
0x4014 = do
                let high :: Addr
high = Byte -> Addr
byteToAddr Byte
byte Addr -> Int -> Addr
forall a. Bits a => a -> Int -> a
`shiftL` Int
8
                [Byte]
bytes <- [Int] -> (Int -> Bus r Byte) -> Bus r [Byte]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
oamDataSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Bus r Byte) -> Bus r [Byte])
-> (Int -> Bus r Byte) -> Bus r [Byte]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
                    Addr -> () -> Bus r Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte (Addr
high Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
+ Word16 -> Addr
Addr (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)) ()
                PPU ((), PPUState) () -> Bus r ()
forall a r. PPU (a, PPUState) a -> Bus r a
liftPPU (PPU ((), PPUState) () -> Bus r ())
-> PPU ((), PPUState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ [Byte] -> PPU ((), PPUState) ()
forall r. [Byte] -> PPU r ()
writeListToOam [Byte]
bytes
                Integer
cycles_ <- Getting Integer BusState Integer -> Bus r Integer
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Integer BusState Integer
Lens' BusState Integer
Nes.Bus.State.cycles
                -- TODO 1) ticks should be done 256 * 2 (as it's a writting operarion) times
                -- TODO 2) Not sure about about the tick count
                Int -> Bus r ()
forall r. Int -> Bus r ()
tick (Int
513 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Integer -> Bool
forall a. Integral a => a -> Bool
odd Integer
cycles_))
            | Addr
idx Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
0x4016 = Controller ((), ControllerState) () -> Bus r ()
forall a r. Controller (a, ControllerState) a -> Bus r a
liftController (Controller ((), ControllerState) () -> Bus r ())
-> Controller ((), ControllerState) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ Byte -> Controller ((), ControllerState) ()
forall r. Byte -> Controller r ()
setStrobe Byte
byte
            | (Addr
0x4000, Addr
0x4017) (Addr, Addr) -> Addr -> Bool
forall a. Ix a => (a, a) -> a -> Bool
`inRange` Addr
idx = APU ((), APUState, InterruptStatus) () -> Bus r ()
forall a r. APU (a, APUState, InterruptStatus) a -> Bus r a
liftAPU (APU ((), APUState, InterruptStatus) () -> Bus r ())
-> APU ((), APUState, InterruptStatus) () -> Bus r ()
forall a b. (a -> b) -> a -> b
$ Addr -> Byte -> APU ((), APUState, InterruptStatus) ()
forall r. Addr -> Byte -> APU r ()
writeToAPU Addr
idx Byte
byte
            | Bool
otherwise = () -> Bus r ()
forall a. a -> Bus r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- liftIO $ printf "Ignoring write at %4x\n" $ unAddr idx
    readAddr :: Addr -> () -> Bus r Addr
readAddr Addr
idx () = do
        Byte
low <- Addr -> () -> Bus r Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte Addr
idx ()
        Byte
high <- Addr -> () -> Bus r Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte (Addr
idx Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
+ Addr
1) ()
        Addr -> Bus r Addr
forall a. a -> Bus r a
forall (m :: * -> *) a. Monad m => a -> m a
return (Addr -> Bus r Addr) -> Addr -> Bus r Addr
forall a b. (a -> b) -> a -> b
$ Byte -> Byte -> Addr
bytesToAddr Byte
low Byte
high

    writeAddr :: Addr -> Addr -> () -> Bus r ()
writeAddr Addr
addr Addr
idx () = do
        let low :: Byte
low = Addr -> Byte
unsafeAddrToByte (Addr
addr Addr -> Addr -> Addr
forall a. Bits a => a -> a -> a
.&. Addr
0xff)
            high :: Byte
high = Addr -> Byte
unsafeAddrToByte (Addr
addr Addr -> Int -> Addr
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
        Byte -> Addr -> () -> Bus r ()
forall a (m :: * -> *).
MemoryInterface a m =>
Byte -> Addr -> a -> m ()
writeByte Byte
low Addr
idx ()
        Byte -> Addr -> () -> Bus r ()
forall a (m :: * -> *).
MemoryInterface a m =>
Byte -> Addr -> a -> m ()
writeByte Byte
high (Addr
idx Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
+ Addr
1) ()

{-# INLINE guardWriteBound #-}
guardWriteBound :: (MonadFail m) => Addr -> m () -> m ()
guardWriteBound :: forall (m :: * -> *). MonadFail m => Addr -> m () -> m ()
guardWriteBound Addr
idx = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Addr
idx Addr -> Addr -> Bool
forall a. Ord a => a -> a -> Bool
< Addr
memorySize)

-- | The continuation will be called with the translated addr to use on the PRG Rom
-- No bound check are necessary
readPrgRomAddr :: (MonadFail m) => Addr -> Rom -> (Addr -> ForeignPtr Word8 -> m a) -> m a
readPrgRomAddr :: forall (m :: * -> *) a.
MonadFail m =>
Addr -> Rom -> (Addr -> ForeignPtr Word8 -> m a) -> m a
readPrgRomAddr Addr
addr Rom
rom Addr -> ForeignPtr Word8 -> m a
cont = do
    let prgRomSize :: Int
prgRomSize = ByteString -> Int
BS.length (Rom -> ByteString
prgRom Rom
rom)
        translatedAddr :: Addr
translatedAddr =
            if Int
prgRomSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x4000 Bool -> Bool -> Bool
&& Addr
addr Addr -> Addr -> Bool
forall a. Ord a => a -> a -> Bool
>= Addr
0x4000
                then Word16 -> Addr
Addr (Word16 -> Addr) -> Word16 -> Addr
forall a b. (a -> b) -> a -> b
$ Addr -> Word16
unAddr Addr
addr Word16 -> Word16 -> Word16
forall a. Integral a => a -> a -> a
`mod` Word16
0x4000
                else Addr
addr
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Addr -> Int
addrToInt Addr
translatedAddr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
prgRomSize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Out-of-bound access in ROM"
    let ptr :: ForeignPtr Word8
ptr = let (BS.BS ForeignPtr Word8
ptr' Int
_) = Rom -> ByteString
prgRom Rom
rom in ForeignPtr Word8
ptr'
    Addr -> ForeignPtr Word8 -> m a
cont Addr
translatedAddr ForeignPtr Word8
ptr