From 63350d5dd9924538949a5c5fc1f47fcc9a92f730 Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Thu, 7 Nov 2019 22:18:32 +0000
Subject: [PATCH] Load and save specification file format

---
 app/MimaRun.hs   | 25 +++++++--------
 package.yaml     |  1 +
 src/Mima/Load.hs | 79 ++++++++++++++++++++++++++++++++----------------
 src/Mima/Word.hs |  5 +++
 4 files changed, 72 insertions(+), 38 deletions(-)

diff --git a/app/MimaRun.hs b/app/MimaRun.hs
index a071d41..4d81885 100644
--- a/app/MimaRun.hs
+++ b/app/MimaRun.hs
@@ -186,17 +186,18 @@ main = do
   settings <- execParser opts
 
   putStrLn $ "Loading memdump at " ++ infile settings
-  mem <- loadMemoryFromFile (infile settings)
+  ms <- loadStateFromFile (infile settings)
+  case ms of
+    Left errorMsg -> putStrLn errorMsg
+    Right s       -> do
+      s' <- if norun settings then pure s else runMima settings s
 
-  let s = initialState mem
-  s' <- if norun settings then pure s else runMima settings s
+      unless (quiet settings) $ do
+        putStrLn ""
+        putStrLn "Dump of MiMa state:"
+        printStateLn (sparse settings) s'
+        putStrLn ""
 
-  unless (quiet settings) $ do
-    putStrLn ""
-    putStrLn "Dump of MiMa state:"
-    printStateLn (sparse settings) s'
-    putStrLn ""
-
-  forM_ (memoryDump settings) $ \path -> do
-    putStrLn $ "Saving memdump at " ++ path
-    saveMemoryToFile path $ msMemory s'
+      forM_ (memoryDump settings) $ \path -> do
+        putStrLn $ "Saving memdump at " ++ path
+        saveStateToFile path s'
diff --git a/package.yaml b/package.yaml
index 6013ce8..6656c21 100644
--- a/package.yaml
+++ b/package.yaml
@@ -21,6 +21,7 @@ description:         Please see the README on GitHub at <https://github.com/Garm
 dependencies:
 - base                 >= 4.7    && < 5
 - ansi-terminal        >= 0.9.1  && < 0.10
+- binary               >= 0.8.6  && < 0.9
 - bytestring           >= 0.10.8 && < 0.11
 - containers           >= 0.6.0  && < 0.7
 - optparse-applicative >= 0.14.3 && < 0.15
diff --git a/src/Mima/Load.hs b/src/Mima/Load.hs
index ed3271a..635a9a5 100644
--- a/src/Mima/Load.hs
+++ b/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
diff --git a/src/Mima/Word.hs b/src/Mima/Word.hs
index de8eabd..62b3a8f 100644
--- a/src/Mima/Word.hs
+++ b/src/Mima/Word.hs
@@ -29,6 +29,11 @@ module Mima.Word
   , SmallValue
   -- ** Converting
   , signedSmallValueToWord
+  -- * Underlying types
+  , WB
+  , MimaWord_
+  , LargeValue_
+  , SmallValue_
   ) where
 
 import           Data.Bits