End-of-stream emulator WIP

3 files changed, 127 insertions, 0 deletions

diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
new file mode 100644
index 0000000..c88033e
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
@@ -0,0 +1,41 @@
+module Fig.Emulator.GB.Component.RAM
+  ( compWRAM
+  ) where
+
+import Fig.Prelude
+import Prelude (fromIntegral)
+
+import qualified Data.Vector as V
+import qualified Data.Vector.Mutable as MV
+import Data.Word (Word8)
+
+import Fig.Emulator.GB.Bus
+
+newtype RAMError = RAMError Text
+  deriving Show
+instance Exception RAMError
+instance Pretty RAMError where
+  pretty (RAMError b) = mconcat
+    [ "internal RAM error: "
+    , b
+    ]
+
+compWRAM :: (MonadIO m, MonadThrow m) => Addr -> Int -> Component m
+compWRAM start size = Component
+  { compState = V.replicate size 0 :: V.Vector Word8
+  , compMatches = \a ->
+      a >= start && a < end
+  , compUpdate = pure
+  , compWrite = \s ad v -> do
+      let offset = fromIntegral . unAddr $ ad - start
+      pure $ V.modify (\ms -> MV.write ms offset v) s
+  , compRead = \s ad -> do
+      let offset = fromIntegral . unAddr $ ad - start
+      case s V.!? offset of
+        Nothing -> throwM . RAMError $ mconcat
+          [ "address ", pretty ad, " out of bounds"
+          ]
+        Just v -> pure v
+  }
+  where
+    end = start + Addr (fromIntegral size)
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
new file mode 100644
index 0000000..b5ea24f
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
@@ -0,0 +1,45 @@
+module Fig.Emulator.GB.Component.ROM
+  ( compROM
+  ) where
+
+import Fig.Prelude
+import Prelude (fromIntegral)
+
+import qualified Data.Vector as V
+import qualified Data.ByteString as BS
+
+import Fig.Emulator.GB.Bus
+
+newtype ROMError = ROMError Text
+  deriving Show
+instance Exception ROMError
+instance Pretty ROMError where
+  pretty (ROMError b) = mconcat
+    [ "internal ROM error: "
+    , b
+    ]
+
+-- | Initialize base ROM (no mapper) from a ByteString
+compROM :: (MonadIO m, MonadThrow m) => ByteString -> Component m
+compROM bs = Component
+  { compState = V.fromList $ BS.unpack bs
+  , compMatches = \a ->
+      a >= start && a < end
+  , compUpdate = pure
+  , compWrite = \s _ad _v ->
+      pure s
+      -- throwM . ROMError $ mconcat
+      -- [ "tried to write to ROM at ", pretty ad
+      -- ]
+  , compRead = \s ad -> do
+      let offset = fromIntegral . unAddr $ ad - start
+      case s V.!? offset of
+        Nothing -> throwM . ROMError $ mconcat
+          [ "address ", pretty ad, " out of bounds"
+          ]
+        Just v -> pure v
+  }
+  where
+    start = 0x0000
+    -- end = 0x4000
+    end = 0x8000
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
new file mode 100644
index 0000000..00f0e4d
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
@@ -0,0 +1,41 @@
+module Fig.Emulator.GB.Component.Video where
+
+import Fig.Prelude
+
+import Fig.Emulator.GB.Bus
+
+newtype VideoError = VideoError Text
+  deriving Show
+instance Exception VideoError
+instance Pretty VideoError where
+  pretty (VideoError b) = mconcat
+    [ "video error: "
+    , b
+    ]
+
+compLCD :: (MonadIO m, MonadThrow m) => Component m
+compLCD = Component
+  { compState = ()
+  , compMatches = \a -> a >= 0xff40 && a <= 0xff4b
+  , compUpdate = pure
+  , compWrite = \s _ _ -> pure s
+  , compRead = \_ (Addr a) -> do
+      let off = a - 0xff40
+      case off of
+        0x0 -> pure 0x00
+        0x1 -> pure 0x00
+        0x2 -> pure 0x00
+        0x3 -> pure 0x00
+        0x4 -> pure 0x00
+        0x5 -> pure 0x00
+        0x6 -> pure 0x00
+        0x7 -> pure 0x00
+        0x8 -> pure 0x00
+        0x9 -> pure 0x00
+        0xa -> pure 0x00
+        0xb -> pure 0x00
+        _ -> throwM $ VideoError $ mconcat
+          [ "address out of bounds for LCD: "
+          , pretty $ Addr a
+          ]
+  }