Initial commit

.gitignore

@@ -0,0 +1,19 @@
+l-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+.HTF/
+

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2017
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1 @@
+# hnes

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

hnes.cabal

@@ -0,0 +1,25 @@
+name:                hnes
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/githubuser/hnes#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Author name here
+maintainer:          [email protected]
+copyright:           2017 Author name here
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+executable hnes
+  hs-source-dirs:      src
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  ghc-options:        -O2 
+                      -rtsopts
+  build-depends:       base >= 4.7 && < 5
+                     , mtl
+                     , vector
+                     , bytestring

roms/Example.nes

@@ -0,0 +1 @@
+NES

src/Emulator.hs

@@ -0,0 +1,58 @@
+module Emulator () where
+
+import           Control.Monad.IO.Class
+import           Data.ByteString.Lazy   as BS hiding (putStrLn, replicate, zip)
+import           Data.Word
+import           Monad
+import           Nes                    (Address (..))
+
+data Opcode
+  = Opcode Word8
+  deriving (Show)
+
+readRom :: FilePath -> IO ByteString
+readRom = BS.readFile
+
+loadRom :: MonadEmulator m => ByteString -> m ()
+loadRom rom = loop 0 where
+  len = BS.length rom
+  loop i
+    | i + 1 >= len = pure ()
+    | otherwise    = do
+      let byte = BS.index rom i
+      let addr = fromIntegral $ i
+      store (Address addr) byte
+      loop (i + 1)
+
+loadOpcode :: MonadEmulator m => m Opcode
+loadOpcode = do
+  pure undefined
+  -- pc  <- load16 Pc
+  -- pcv <- load8 (Ram pc)
+  -- pure $ Opcode pcv
+
+executeOpcode :: (MonadIO m, MonadEmulator m) => Opcode -> m ()
+executeOpcode opcode = do
+  liftIO $ putStrLn (show opcode)
+  -- pc <- load16 Pc
+  -- store16 Pc (pc + 1)
+  pure undefined
+
+emulate :: (MonadIO m, MonadEmulator m) => m ()
+emulate = do
+  opcode <- loadOpcode
+  executeOpcode opcode
+  liftIO $ putStrLn "In emulate"
+  emulate
+
+run :: FilePath -> IO ()
+run fp = runIOEmulator $ do
+  rom <- liftIO $ readRom fp
+  loadedRom <- loadRom rom
+  emulate
+
+runExample :: IO ()
+runExample = run "roms/Example.nes"
+
+runDrMario :: IO ()
+runDrMario = run "roms/Dr_Mario.nes"

src/Log.hs

@@ -0,0 +1,9 @@
+module Log (
+  -- * Types
+  -- * Functions
+) where
+
+import           Memory (Address (..))
+import           Monad  (MonadEmulator (..))
+import           Util
+

src/Main.hs

@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = putStrLn "hello world"

src/Monad.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Monad (
+  -- * Types
+    MonadEmulator(..)
+  -- * Functions
+  , runIOEmulator
+) where
+
+import           Control.Monad.IO.Class
+import           Control.Monad.Reader   (ReaderT, ask, runReaderT)
+import           Control.Monad.ST       (RealWorld, stToIO)
+import           Control.Monad.Trans    (MonadIO, lift)
+import           Data.Semigroup         ((<>))
+import           Data.Word
+import           Nes
+import           Util
+
+class Monad m => MonadEmulator m where
+  load8 :: Address -> m Word8
+  load16 :: Address -> m Word16
+  readRegister :: Register -> m Word8
+  store :: Address -> Word8 -> m ()
+  trace :: String -> m ()
+
+newtype IOEmulator a = IOEmulator (ReaderT (Nes RealWorld)  IO a)
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+instance MonadEmulator IOEmulator where
+  load8 address = IOEmulator $ do
+    mem <- ask
+    lift $ stToIO $ Nes.readMemory mem address
+  load16 addr @ (Address a) = IOEmulator $ do
+    mem <- ask
+    lift $ stToIO $ do
+      l  <- Nes.readMemory mem addr
+      r <- Nes.readMemory mem (Address (a + 1))
+      pure $ makeW16 l r
+  store address word = IOEmulator $ do
+    mem <- ask
+    lift $ stToIO $ Nes.writeMemory mem address word
+  trace msg = IOEmulator $ do
+    mem <- ask
+    r <- lift $ stToIO $ Nes.render mem
+    liftIO $ print (msg <> " " <> r)
+
+runIOEmulator :: IOEmulator a -> IO a
+runIOEmulator (IOEmulator reader) = do
+  mem <- stToIO Nes.new
+  runReaderT reader mem

src/Nes.hs

@@ -0,0 +1,81 @@
+module Nes (
+  -- * Types
+    Nes(..)
+  , Address(..)
+  -- * Functions
+  , new
+  , readMemory
+  , writeMemory
+  , render
+) where
+
+import           Control.Monad.ST
+import           Data.STRef                  (STRef, modifySTRef', newSTRef,
+                                              readSTRef)
+import qualified Data.Vector.Unboxed.Mutable as VUM
+import           Data.Word
+import           Prelude                     hiding (replicate)
+import           Util
+
+data Nes s = Nes {
+  memory :: VUM.MVector s Word8,
+  xReg   :: STRef       s Word8
+}
+
+data Register
+  = Pc
+  | Sp
+  | P
+  | A
+  | X
+  | Y
+  deriving (Eq)
+
+instance Show Register where
+  show Pc = "Pc"
+  show Sp = "Sp"
+  show P  = "Status"
+  show A  = "A"
+  show X  = "X"
+  show Y  = "Y"
+
+data Address
+  = Address Word16
+  deriving (Eq)
+
+instance Show Address where
+  show (Address r) = "[" ++ prettifyWord16 r ++ "]"
+
+fromAddress :: Address -> Int
+fromAddress (Address a) =  fromIntegral a
+
+fromRegister :: Register -> (Nes s -> STRef s Word8)
+fromRegister reg = case reg of
+  X -> xReg
+  _ -> undefined
+
+new :: ST s (Nes s)
+new = do
+  mem <- VUM.replicate 65536 0
+  x <- newSTRef 0
+  pure $ Nes mem x
+
+readMemory :: Nes s -> Address -> ST s Word8
+readMemory (Nes mem _) = VUM.read mem . fromAddress
+
+writeMemory :: Nes s -> Address -> Word8 -> ST s ()
+writeMemory (Nes mem _) = VUM.write mem . fromAddress
+
+setRegister :: Nes s -> Register -> Word8 -> ST s ()
+setRegister nes reg value = modifySTRef' (fromRegister reg nes) (const value)
+
+readRegister :: Nes s -> Register -> ST s Word8
+readRegister nes reg = readSTRef $ fromRegister reg nes
+
+render :: Nes s -> ST s String
+render mem = unlines <$> mapM line [(x * 8, x * 8 + 7) | x <- [0 .. 0xffff `div` 8]]
+  where
+    line (lo, up) = do
+      vs <- mapM (readMemory mem . Address) [lo .. up]
+      return $ prettifyWord16 lo ++ ": " ++ unwords (map show vs)
+

src/Util.hs

@@ -0,0 +1,16 @@
+module Util (
+  -- * Functions
+    prettifyWord16
+  , makeW16
+) where
+
+import           Data.Bits   (shiftL, (.|.))
+import           Data.Word   (Word16, Word8)
+import           Text.Printf (printf)
+
+
+prettifyWord16 :: Word16 -> String
+prettifyWord16 = printf "%04x"
+
+makeW16 :: Word8 -> Word8 -> Word16
+makeW16 l h = (fromIntegral l :: Word16) .|. (fromIntegral h :: Word16) `shiftL` 8

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-9.0
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.3"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor