use ExceptT transformer to clarify interpreter code

src/Language/Wasm/Interpreter.hs

@@ -50,6 +50,8 @@ import Data.Bits (
         countTrailingZeros
     )
 import Numeric.IEEE (IEEE, copySign, minNum, maxNum, identicalIEEE)
+import Control.Monad.Except (ExceptT, runExceptT, throwError)
+import Control.Monad.IO.Class (liftIO)
 
 import Debug.Trace as Debug
 
@@ -484,28 +486,26 @@ allocMems mems = Vector.fromList <$> mapM allocMem mems
                 memory
             }
 
-initialize :: ModuleInstance -> Module -> Store -> IO (Either String Store)
+type Initialize = ExceptT String IO
+
+initialize :: ModuleInstance -> Module -> Store -> Initialize Store
 initialize inst Module {elems, datas, start} store = do
-    checkedMems <- Monad.foldM checkData (Right store) datas
+    checkedMems <- Monad.foldM checkData store datas
     checkedTables <- Monad.foldM checkElem checkedMems elems
     storeWithTables <- Monad.foldM initElem checkedMems elems
-    storeWithMems <- Monad.foldM initData storeWithTables datas
-    case storeWithMems of
-        Right st -> do
-            case start of
-                Just (StartFunction idx) -> do
-                    let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx)
-                    mainRes <- eval defaultBudget st funInst []
-                    case mainRes of
-                        Just [] -> return $ Right st
-                        _ -> return $ Left "Start function terminated with trap"
-                Nothing -> return $ Right st
-        Left reason -> return $ Left reason
+    st <- Monad.foldM initData storeWithTables datas
+    case start of
+        Just (StartFunction idx) -> do
+            let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx)
+            mainRes <- liftIO $ eval defaultBudget st funInst []
+            case mainRes of
+                Just [] -> return st
+                _ -> throwError "Start function terminated with trap"
+        Nothing -> return st
     where
-        checkElem :: Either String Store -> ElemSegment -> IO (Either String Store)
-        checkElem (Left err) _ = return $ Left err
-        checkElem (Right st) ElemSegment {tableIndex, offset, funcIndexes} = do
-            VI32 val <- evalConstExpr inst st offset
+        checkElem :: Store -> ElemSegment -> Initialize Store
+        checkElem st ElemSegment {tableIndex, offset, funcIndexes} = do
+            VI32 val <- liftIO $ evalConstExpr inst st offset
             let from = fromIntegral val
             let funcs = map ((funcaddrs inst !) . fromIntegral) funcIndexes
             let idx = tableaddrs inst ! fromIntegral tableIndex
@@ -513,13 +513,12 @@ initialize inst Module {elems, datas, start} store = do
             let TableInstance lim elems = tableInstances st ! idx
             let len = Vector.length elems
             if last > len
-            then return $ Left "elements segment does not fit"
-            else return $ Right st
+            then throwError "elements segment does not fit"
+            else return st
 
-        initElem :: Either String Store -> ElemSegment -> IO (Either String Store)
-        initElem (Left err) _ = return $ Left err
-        initElem (Right st) ElemSegment {tableIndex, offset, funcIndexes} = do
-            VI32 val <- evalConstExpr inst st offset
+        initElem :: Store -> ElemSegment -> Initialize Store
+        initElem st ElemSegment {tableIndex, offset, funcIndexes} = do
+            VI32 val <- liftIO $ evalConstExpr inst st offset
             let from = fromIntegral val
             let funcs = map ((funcaddrs inst !) . fromIntegral) funcIndexes
             let idx = tableaddrs inst ! fromIntegral tableIndex
@@ -527,36 +526,34 @@ initialize inst Module {elems, datas, start} store = do
             let TableInstance lim elems = tableInstances st ! idx
             let len = Vector.length elems
             if last > len
-            then return $ Left "elements segment does not fit"
+            then throwError "elements segment does not fit"
             else do
                 let table = TableInstance lim (elems // zip [from..] (map Just funcs))
-                return $ Right st { tableInstances = tableInstances st Vector.// [(idx, table)] }
+                return st { tableInstances = tableInstances st Vector.// [(idx, table)] }
 
-        checkData :: Either String Store -> DataSegment -> IO (Either String Store)
-        checkData (Left err) _ = return $ Left err
-        checkData (Right st) DataSegment {memIndex, offset, chunk} = do
-            VI32 val <- evalConstExpr inst st offset
+        checkData :: Store -> DataSegment -> Initialize Store
+        checkData st DataSegment {memIndex, offset, chunk} = do
+            VI32 val <- liftIO $ evalConstExpr inst st offset
             let from = fromIntegral val
             let idx = memaddrs inst ! fromIntegral memIndex
             let last = from + (fromIntegral $ LBS.length chunk)
             let MemoryInstance _ memory = memInstances st ! idx
-            mem <- readIORef memory
+            mem <- liftIO $ readIORef memory
             let len = IOVector.length mem
             if last > len
-            then return $ Left "data segment does not fit"
-            else return $ Right st
+            then throwError "data segment does not fit"
+            else return st
 
-        initData :: Either String Store -> DataSegment -> IO (Either String Store)
-        initData (Left err) _ = return $ Left err
-        initData (Right st) DataSegment {memIndex, offset, chunk} = do
-            VI32 val <- evalConstExpr inst st offset
+        initData :: Store -> DataSegment -> Initialize Store
+        initData st DataSegment {memIndex, offset, chunk} = do
+            VI32 val <- liftIO $ evalConstExpr inst st offset
             let from = fromIntegral val
             let idx = memaddrs inst ! fromIntegral memIndex
             let last = from + (fromIntegral $ LBS.length chunk)
             let MemoryInstance _ memory = memInstances st ! idx
-            mem <- readIORef memory
+            mem <- liftIO $ readIORef memory
             mapM_ (\(i,b) -> IOVector.write mem i b) $ zip [from..] $ LBS.unpack chunk
-            return $ Right st
+            return st
 
 instantiate :: Store -> Imports -> Module -> IO (Either String (ModuleInstance, Store))
 instantiate st imps m =
@@ -567,7 +564,7 @@ instantiate st imps m =
             globals <- (globalInstances st <>) <$> (allocAndInitGlobals inst st $ Struct.globals m)
             let tables = tableInstances st <> (allocTables $ Struct.tables m)
             mems <- (memInstances st <>) <$> (allocMems $ Struct.mems m)
-            st' <- initialize inst m $ st {
+            st' <- runExceptT $ initialize inst m $ st {
                 funcInstances = functions,
                 tableInstances = tables,
                 memInstances = mems,