Load and save specification file format

src/Mima/Load.hs

@@ -1,39 +1,66 @@
+{-# LANGUAGE FlexibleInstances #-}
+
 module Mima.Load
-  ( loadMemoryFromFile
-  , saveMemoryToFile
+  ( loadStateFromFile
+  , saveStateToFile
   ) where
 
-import           Data.Bits
-import qualified Data.ByteString as BS
-import           Data.Word
+import           Control.Applicative
+import           Data.Binary
+import qualified Data.ByteString.Lazy as BS
 
 import           Mima.Word
 import           Mima.State
 
--- These two functions are implemented with explicit recursion. The
--- first because it was easier to write that way, and the second in
--- the hopes of better performance regarding list concatenation.
+-- To prevent orphan instances and keep the compiler happy
+newtype LD t = LD { unLD :: t }
 
-bytesToWords :: [Word8] -> [MimaWord]
-bytesToWords (w1:w2:w3:ws) =  bytesToWord w1 w2 w3 : bytesToWords ws
-bytesToWords [w1,w2]       = [bytesToWord w1 w2       zeroBits]
-bytesToWords [w1]          = [bytesToWord w1 zeroBits zeroBits]
-bytesToWords []            = []
+instance Binary (LD (WB MimaWord_)) where
+  put mw = do
+    let (w1, w2, w3) = wordToBytes $ unLD mw
+    put w1
+    put w2
+    put w3
+  get = do
+    w1 <- get
+    w2 <- get
+    w3 <- get
+    pure $ LD $ bytesToWord w1 w2 w3
 
-wordsToBytes :: [MimaWord] -> [Word8]
-wordsToBytes []     = []
-wordsToBytes (w:ws) =
-  let (w1, w2, w3) = wordToBytes w
-  in  w1 : w2 : w3 : wordsToBytes ws
+instance Binary (LD (WB LargeValue_)) where
+  put = put . LD . largeValueToWord . unLD
+  get = (LD . getLargeValue) <$> unLD <$> get
 
-bsToWords :: BS.ByteString -> [MimaWord]
-bsToWords = bytesToWords . BS.unpack
+instance Binary (LD MimaMemory) where
+  put = mapM_ (put . LD) . memoryToWords . unLD
+  get = (LD . wordsToMemory . map unLD) <$> many get
 
-wordsToBs :: [MimaWord] -> BS.ByteString
-wordsToBs = BS.pack . wordsToBytes
+instance Binary (LD MimaState) where
+  put ldms = do
+    let ms = unLD ldms
+    put $ LD $ msIAR ms
+    put $ LD $ msACC ms
+    put $ LD $ msRA ms
+    put $ LD $ msSP ms
+    put $ LD $ msFP ms
+    put $ LD $ msMemory ms
+  get = do
+    iar <- unLD <$> get
+    acc <- unLD <$> get
+    ra  <- unLD <$> get
+    sp  <- unLD <$> get
+    fp  <- unLD <$> get
+    mem <- unLD <$> get
+    pure $ LD $ MimaState iar acc ra sp fp mem
 
-loadMemoryFromFile :: FilePath -> IO MimaMemory
-loadMemoryFromFile path = (wordsToMemory . bsToWords) <$> BS.readFile path
+loadStateFromFile :: FilePath -> IO (Either String MimaState)
+loadStateFromFile path = do
+  bs <- BS.readFile path
+  pure $ case decodeOrFail bs of
+    Left  (  _, _, e) -> Left e
+    Right (bs', _, ldms)
+      | BS.null bs' -> Right $ unLD ldms
+      | otherwise   -> Left "Input was not consumed fully"
 
-saveMemoryToFile :: FilePath -> MimaMemory -> IO ()
-saveMemoryToFile path = BS.writeFile path . wordsToBs . memoryToWords
+saveStateToFile :: FilePath -> MimaState -> IO ()
+saveStateToFile path = BS.writeFile path . encode . LD

src/Mima/Word.hs

@@ -29,6 +29,11 @@ module Mima.Word
   , SmallValue
   -- ** Converting
   , signedSmallValueToWord
+  -- * Underlying types
+  , WB
+  , MimaWord_
+  , LargeValue_
+  , SmallValue_
   ) where
 
 import           Data.Bits