diff --git a/core/src/Machine/GBC/Emulator.hs b/core/src/Machine/GBC/Emulator.hs index 709c90c..5480e51 100644 --- a/core/src/Machine/GBC/Emulator.hs +++ b/core/src/Machine/GBC/Emulator.hs @@ -171,6 +171,7 @@ updateHardware :: Int -> Int -> ReaderT EmulatorState IO Graphics.BusEvent updateHardware cycles cpuClocks = do EmulatorState {..} <- ask liftIO $ do + Serial.update serialState cycles Timer.update timerState cycles Audio.step audioState cpuClocks Graphics.step graphicsState graphicsSync cpuClocks diff --git a/core/src/Machine/GBC/Serial.hs b/core/src/Machine/GBC/Serial.hs index cad85a0..c1c49e2 100644 --- a/core/src/Machine/GBC/Serial.hs +++ b/core/src/Machine/GBC/Serial.hs @@ -85,8 +85,8 @@ notifyIncoming State {..} period incomingValue = do writeIORef transferActiveRef True -- | Advance the serial clock. -update :: Int -> State -> IO () -update cycles State {..} = do +update :: State -> Int -> IO () +update State {..} cycles = do transferActive <- readIORef transferActiveRef when transferActive $ do reloads <- updateReloadingCounter shiftClock cycles $ readUnboxedRef clockPeriod diff --git a/core/test/Machine/GBC/CPUSpec.hs b/core/test/Machine/GBC/CPUSpec.hs index a188305..459c066 100644 --- a/core/test/Machine/GBC/CPUSpec.hs +++ b/core/test/Machine/GBC/CPUSpec.hs @@ -2,7 +2,10 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -module Machine.GBC.CPUSpec where +module Machine.GBC.CPUSpec + ( spec + ) +where import Control.Monad import Control.Monad.IO.Class diff --git a/core/test/Machine/GBC/DecodeSpec.hs b/core/test/Machine/GBC/DecodeSpec.hs index ea2dccb..3a262f5 100644 --- a/core/test/Machine/GBC/DecodeSpec.hs +++ b/core/test/Machine/GBC/DecodeSpec.hs @@ -4,7 +4,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NumericUnderscores #-} -module Machine.GBC.DecodeSpec where +module Machine.GBC.DecodeSpec + ( spec + ) +where import Control.Monad.Reader import Control.Monad.State diff --git a/core/test/Machine/GBC/EmulatorSpec.hs b/core/test/Machine/GBC/EmulatorSpec.hs index 4b6c97b..f1fe356 100644 --- a/core/test/Machine/GBC/EmulatorSpec.hs +++ b/core/test/Machine/GBC/EmulatorSpec.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module Machine.GBC.EmulatorSpec where +module Machine.GBC.EmulatorSpec + ( spec + ) +where import Data.List import Foreign.Ptr diff --git a/hie.yaml b/hie.yaml index 8f02501..2dc25d3 100644 --- a/hie.yaml +++ b/hie.yaml @@ -6,5 +6,7 @@ cradle: component: "hgbc-core:lib" - path: "./main/src" component: "hgbc-main:lib" + - path: "./testing/src" + component: "hgbc-testing:test:hgbc-testing" - path: "./sdl/src" component: "hgbc-sdl:exe:hgbc-sdl" diff --git a/stack.yaml b/stack.yaml index 6e21a37..b11d51e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,6 +31,7 @@ resolver: lts-14.27 packages: - core - main +- testing - sdl # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as diff --git a/testing/.gitignore b/testing/.gitignore new file mode 100644 index 0000000..1c544c4 --- /dev/null +++ b/testing/.gitignore @@ -0,0 +1 @@ +roms \ No newline at end of file diff --git a/testing/hgbc-testing.cabal b/testing/hgbc-testing.cabal new file mode 100644 index 0000000..a2758d0 --- /dev/null +++ b/testing/hgbc-testing.cabal @@ -0,0 +1,43 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 3162654447ea9adb7faf009f19d31f984aefc9df01d5a54d65de5eb10150579e + +name: hgbc-testing +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/CLowcay/hgbc#readme +bug-reports: https://github.com/CLowcay/hgbc/issues +author: Callum Lowcay +maintainer: cwslowcay@gmail.com +copyright: 2019-2020 Callum Lowcay +license: BSD3 +build-type: Simple +extra-source-files: + ../README.md + +source-repository head + type: git + location: https://github.com/CLowcay/hgbc + +test-suite hgbc-testing + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_hgbc_testing + hs-source-dirs: + src + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Wpartial-fields + build-depends: + base >=4.7 && <5 + , bytestring + , directory + , filepath + , hgbc-core + , hspec + , mtl + , temporary + default-language: Haskell2010 diff --git a/testing/package.yaml b/testing/package.yaml new file mode 100644 index 0000000..ed43489 --- /dev/null +++ b/testing/package.yaml @@ -0,0 +1,44 @@ +name: hgbc-testing +version: 0.1.0.0 +github: "CLowcay/hgbc" +license: BSD3 +author: "Callum Lowcay" +maintainer: "cwslowcay@gmail.com" +copyright: "2019-2020 Callum Lowcay" + +extra-source-files: +- ../README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- bytestring +- directory +- filepath +- hgbc-core +- hspec +- mtl +- temporary + +tests: + hgbc-testing: + main: Main.hs + source-dirs: src + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall + - -Wcompat + - -Wincomplete-uni-patterns + - -Wincomplete-record-updates + - -Wredundant-constraints + - -Wpartial-fields diff --git a/testing/src/Main.hs b/testing/src/Main.hs new file mode 100644 index 0000000..d67eeb9 --- /dev/null +++ b/testing/src/Main.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) +where + +import Control.Concurrent +import Control.Exception +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Writer +import Data.IORef +import Data.Word +import Foreign.Marshal.Alloc +import Machine.GBC +import System.Directory +import System.FilePath +import System.IO.Temp +import Test.Hspec +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as LB +import qualified Machine.GBC.CPU as CPU +import qualified Machine.GBC.Graphics as Graphics +import qualified Machine.GBC.Memory as Memory +import qualified Machine.GBC.Serial as Serial + +main :: IO () +main = hspec $ describe "blargg suite" $ do + specify "cpu_instrs" $ do + output <- blarggTest "roms/blargg/cpu_instrs.gb" Serial 0x06f1 + output + `shouldBe` "cpu_instrs\n\n01:ok 02:ok 03:ok 04:ok 05:ok 06:ok 07:ok 08:ok 09:ok 10:ok 11:ok \n\nPassed all tests\n" + specify "instr_timing" $ do + output <- blarggTest "roms/blargg/instr_timing.gb" Serial 0xC8B0 + output `shouldBe` "instr_timing\n\n\nPassed\n" + specify "mem_timing" $ do + output <- blarggTest "roms/blargg/mem_timing.gb" InMemory 0x2BDD + output `shouldBe` "mem_timing\n\n01:ok 02:ok 03:ok \n\nPassed\n" + specify "cgb_sound" $ do + output <- blarggTest "roms/blargg/cgb_sound.gb" InMemory 0x2BD4 + output + `shouldBe` "cgb_sound\n\n01:ok 02:ok 03:ok 04:ok 05:ok 06:ok 07:ok 08:ok 09:ok 10:ok 11:ok 12:ok \n\nPassed\n" + specify "halt_bug" $ do + output <- blarggTest "roms/blargg/halt_bug.gb" InMemory 0xC818 + output + `shouldBe` "halt bug\n\nIE IF IF DE\n01 10 F1 0C04 \n01 00 E1 0C04 \n01 01 E1 0411 \n11 00 E1 0C04 \n11 10 F1 0411 \n11 11 F1 0411 \nE1 00 E1 0C04 \nE1 E0 E1 0C04 \nE1 E1 E1 0411 \n\nPassed\n" + +data TestComplete = TestComplete deriving (Eq, Show) +instance Exception TestComplete + +data BlarggOutputStyle = Serial | InMemory deriving (Eq, Show) + +blarggTest :: FilePath -> BlarggOutputStyle -> Word16 -> IO B.ByteString +blarggTest filename outputStyle terminalAddress = + withSystemTempDirectory "rom-testing" $ \tempDir -> do + let baseName = takeBaseName filename + createDirectoryIfMissing True (tempDir baseName) + let paths = ROMPaths { romFile = filename + , romSaveFile = tempDir baseName "battery" + , romRTCFile = tempDir baseName "rtc" + } + + romData <- B.readFile filename + (eROM, warnings) <- runWriterT (runExceptT (parseROM paths romData)) + unless (null warnings) $ fail (show warnings) + case eROM of + Left err -> fail (show err) + Right rom -> allocaBytes (160 * 144 * 4) $ \frameBuffer -> do + serialSync <- Serial.newSync + gs <- newSync + buffer <- newIORef "" + bracket (serialHandler serialSync buffer) (`throwTo` TestComplete) $ \_ -> + bracket (nullGraphics gs) (`throwTo` TestComplete) $ \_ -> do + emulatorState <- initEmulatorState Nothing + rom + Nothing + DefaultColorCorrection + serialSync + gs + frameBuffer + runReaderT (reset >> runLoop) emulatorState + case outputStyle of + InMemory -> flip runReaderT emulatorState $ do + Memory.writeByte 0 0x0A + liftIO . writeIORef buffer =<< readString 0xA004 + _ -> pure () + LB.toStrict . BB.toLazyByteString <$> readIORef buffer + + where + runLoop = do + step + pc <- CPU.readPC + if pc == terminalAddress then pure () else runLoop + + readString = readString0 "" + where + readString0 !acc addr = do + b <- Memory.readByte addr + if b == 0 then pure acc else readString0 (acc <> BB.word8 b) (addr + 1) + + serialHandler sync buffer = case outputStyle of + Serial -> accumulateSerialOutput sync buffer + InMemory -> ignoreSerialOutput sync + + ignoreSerialOutput sync = forkIO $ foreverUntil TestComplete $ do + void (takeMVar (Serial.out sync)) + putMVar (Serial.inp sync) 0xFF + accumulateSerialOutput sync buffer = forkIO $ foreverUntil TestComplete $ do + byte <- takeMVar (Serial.out sync) + putMVar (Serial.inp sync) 0xFF + modifyIORef' buffer (<> BB.word8 byte) + nullGraphics gs = forkIO $ foreverUntil TestComplete $ do + takeMVar (Graphics.signalWindow gs) + putMVar (Graphics.bufferAvailable gs) () + foreverUntil e action = forever action `catch` (\ex -> if e == ex then pure () else throwIO ex)