Haskell bindings: use ExceptT instead of deprecated EitherT (#1034)

Backports commit 873fffc505b29c6179a8aece18b7e331e5f879e8 from unicorn.

bindings/haskell/src/Unicorn.hs

@@ -53,9 +53,9 @@ module Unicorn
     , version
     ) where
 
-import Control.Monad (liftM)
+import Control.Monad (join, liftM)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Either (hoistEither, left, right, runEitherT)
+import Control.Monad.Trans.Except (throwE, runExceptT)
 import Data.ByteString (ByteString, pack)
 import Foreign
 import Prelude hiding (until)
@@ -73,7 +73,7 @@ runEmulator :: Emulator a           -- ^ The emulation code to execute
             -> IO (Either Error a)  -- ^ A result on success, or an 'Error' on
                                     -- failure
 runEmulator =
-    runEitherT
+    runExceptT
 
 -- | Create a new instance of the Unicorn engine.
 open :: Architecture    -- ^ CPU architecture
@@ -88,7 +88,7 @@ open arch mode = do
         lift $ mkEngine ucPtr
     else
         -- Otherwise return the error
-        left err
+        throwE err
 
 -- | Query internal status of the Unicorn engine.
 query :: Engine         -- ^ 'Unicorn' engine handle
@@ -97,9 +97,9 @@ query :: Engine         -- ^ 'Unicorn' engine handle
 query uc queryType = do
     (err, result) <- lift $ ucQuery uc queryType
     if err == ErrOk then
-        right result
+        pure result
     else
-        left err
+        throwE err
 
 -- | Emulate machine code for a specific duration of time.
 start :: Engine         -- ^ 'Unicorn' engine handle
@@ -117,9 +117,9 @@ start :: Engine         -- ^ 'Unicorn' engine handle
 start uc begin until timeout count = do
     err <- lift $ ucEmuStart uc begin until (maybeZ timeout) (maybeZ count)
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
     where maybeZ = maybe 0 id
 
 -- | Stop emulation (which was started by 'start').
@@ -131,9 +131,9 @@ stop :: Engine      -- ^ 'Unicorn' engine handle
 stop uc = do
     err <- lift $ ucEmuStop uc
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -------------------------------------------------------------------------------
 -- Register operations
@@ -148,9 +148,9 @@ regWrite :: Reg r
 regWrite uc reg value = do
     err <- lift $ ucRegWrite uc reg value
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -- | Read register value.
 regRead :: Reg r
@@ -161,9 +161,9 @@ regRead :: Reg r
 regRead uc reg = do
     (err, val) <- lift $ ucRegRead uc reg
     if err == ErrOk then
-        right val
+        pure val
     else
-        left err
+        throwE err
 
 -- | Write multiple register values.
 regWriteBatch :: Reg r
@@ -174,9 +174,9 @@ regWriteBatch :: Reg r
 regWriteBatch uc regs vals = do
     err <- lift $ ucRegWriteBatch uc regs vals (length regs)
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -- | Read multiple register values.
 regReadBatch ::  Reg r
@@ -187,16 +187,15 @@ regReadBatch ::  Reg r
 regReadBatch uc regs = do
     -- Allocate an array of the given size
     let size = length regs
-    result <- lift . allocaArray size $ \array -> do
+    join . lift . allocaArray size $ \array -> do
         err <- ucRegReadBatch uc regs array size
         if err == ErrOk then
             -- If ucRegReadBatch completed successfully, pack the contents of
             -- the array into a list and return it
-            liftM Right (peekArray size array)
+            liftM pure (peekArray size array)
         else
             -- Otherwise return the error
-            return $ Left err
+            return $ throwE err
-    hoistEither result
 
 -------------------------------------------------------------------------------
 -- Memory operations
@@ -210,9 +209,9 @@ memWrite :: Engine      -- ^ 'Unicorn' engine handle
 memWrite uc address bytes = do
     err <- lift $ ucMemWrite uc address bytes
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -- | Read memory contents.
 memRead :: Engine                       -- ^ 'Unicorn' engine handle
@@ -223,16 +222,15 @@ memRead :: Engine                       -- ^ 'Unicorn' engine handle
                                         -- an 'Error' on failure
 memRead uc address size = do
     -- Allocate an array of the given size
-    result <- lift . allocaArray size $ \array -> do
+    join . lift . allocaArray size $ \array -> do
         err <- ucMemRead uc address array size
         if err == ErrOk then
             -- If ucMemRead completed successfully, pack the contents of the
             -- array into a ByteString and return it
-            liftM (Right . pack) (peekArray size array)
+            liftM (pure . pack) (peekArray size array)
         else
             -- Otherwise return the error
-            return $ Left err
+            return $ throwE err
-    hoistEither result
 
 -- | Map a range of memory.
 memMap :: Engine                -- ^ 'Unicorn' engine handle
@@ -248,9 +246,9 @@ memMap :: Engine                -- ^ 'Unicorn' engine handle
 memMap uc address size perms = do
     err <- lift $ ucMemMap uc address size perms
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -- | Unmap a range of memory.
 memUnmap :: Engine      -- ^ 'Unicorn' engine handle
@@ -264,9 +262,9 @@ memUnmap :: Engine      -- ^ 'Unicorn' engine handle
 memUnmap uc address size = do
     err <- lift $ ucMemUnmap uc address size
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -- | Change permissions on a range of memory.
 memProtect :: Engine                -- ^ 'Unicorn' engine handle
@@ -283,9 +281,9 @@ memProtect :: Engine                -- ^ 'Unicorn' engine handle
 memProtect uc address size perms = do
     err <- lift $ ucMemProtect uc address size perms
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -- | Retrieve all memory regions mapped by 'memMap'. 
 memRegions :: Engine                    -- ^ 'Unicorn' engine handle
@@ -294,9 +292,9 @@ memRegions uc = do
     (err, regionPtr, count) <- lift $ ucMemRegions uc
     if err == ErrOk then do
         regions <- lift $ peekArray count regionPtr
-        right regions
+        pure regions
     else
-        left err
+        throwE err
 
 -------------------------------------------------------------------------------
 -- Context operations
@@ -314,7 +312,7 @@ contextAllocate uc = do
         -- Return a CPU context if ucContextAlloc completed successfully
         lift $ mkContext contextPtr
     else
-        left err
+        throwE err
 
 -- | Save a copy of the internal CPU context.
 contextSave :: Engine       -- ^ 'Unicorn' engine handle
@@ -323,9 +321,9 @@ contextSave :: Engine       -- ^ 'Unicorn' engine handle
 contextSave uc context = do
     err <- lift $ ucContextSave uc context
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -- | Restore the current CPU context from a saved copy.
 contextRestore :: Engine        -- ^ 'Unicorn' engine handle
@@ -334,9 +332,9 @@ contextRestore :: Engine        -- ^ 'Unicorn' engine handle
 contextRestore uc context = do
     err <- lift $ ucContextRestore uc context
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -------------------------------------------------------------------------------
 -- Misc.

bindings/haskell/src/Unicorn/Hook.hs

@@ -39,7 +39,7 @@ module Unicorn.Hook
 
 import Control.Monad
 import Control.Monad.Trans.Class
-import Control.Monad.Trans.Either (hoistEither, left, right)
+import Control.Monad.Trans.Except (ExceptT (..), throwE)
 import Foreign
 
 import Unicorn.Internal.Core
@@ -60,12 +60,11 @@ codeHookAdd :: Storable a
             -> Word64           -- ^ End address
             -> Emulator Hook    -- ^ The hook handle on success, or an 'Error'
                                 -- on failure
-codeHookAdd uc callback userData begin end = do
+codeHookAdd uc callback userData begin end =
-    result <- lift . alloca $ \userDataPtr -> do
+    ExceptT . alloca $ \userDataPtr -> do
         poke userDataPtr userData
         funPtr <- marshalCodeHook callback
         getResult $ ucHookAdd uc HookCode funPtr userDataPtr begin end
-    hoistEither result
 
 -- | Register a callback for an interrupt hook event.
 interruptHookAdd :: Storable a
@@ -77,12 +76,11 @@ interruptHookAdd :: Storable a
                  -> Word64          -- ^ End address
                  -> Emulator Hook   -- ^ The hook handle on success, or 'Error'
                                     -- on failure
-interruptHookAdd uc callback userData begin end = do
+interruptHookAdd uc callback userData begin end =
-    result <- lift . alloca $ \userDataPtr -> do
+    ExceptT . alloca $ \userDataPtr -> do
         poke userDataPtr userData
         funPtr <- marshalInterruptHook callback
         getResult $ ucHookAdd uc HookIntr funPtr userDataPtr begin end
-    hoistEither result
 
 -- | Register a callback for a block hook event.
 blockHookAdd :: Storable a
@@ -94,12 +92,11 @@ blockHookAdd :: Storable a
              -> Word64          -- ^ End address
              -> Emulator Hook   -- ^ The hook handle on success, or an 'Error'
                                 -- on failure
-blockHookAdd uc callback userData begin end = do
+blockHookAdd uc callback userData begin end =
-    result <- lift . alloca $ \userDataPtr -> do
+    ExceptT . alloca $ \userDataPtr -> do
         poke userDataPtr userData
         funPtr <- marshalBlockHook callback
         getResult $ ucHookAdd uc HookBlock funPtr userDataPtr begin end
-    hoistEither result
 
 -- | Register a callback for an IN instruction hook event (X86).
 inHookAdd :: Storable a
@@ -111,13 +108,12 @@ inHookAdd :: Storable a
           -> Word64         -- ^ End address
           -> Emulator Hook  -- ^ The hook handle on success, or an 'Error' on
                             -- failure
-inHookAdd uc callback userData begin end = do
+inHookAdd uc callback userData begin end =
-    result <- lift . alloca $ \userDataPtr -> do
+    ExceptT . alloca $ \userDataPtr -> do
         poke userDataPtr userData
         funPtr <- marshalInHook callback
         getResult $ ucInsnHookAdd uc HookInsn funPtr userDataPtr begin end
                                   X86.In
-    hoistEither result
 
 -- | Register a callback for an OUT instruction hook event (X86).
 outHookAdd :: Storable a
@@ -129,13 +125,12 @@ outHookAdd :: Storable a
            -> Word64        -- ^ End address
            -> Emulator Hook -- ^ The hook handle on success, or an 'Error' on
                             -- failure
-outHookAdd uc callback userData begin end = do
+outHookAdd uc callback userData begin end =
-    result <- lift . alloca $ \userDataPtr -> do
+    ExceptT . alloca $ \userDataPtr -> do
         poke userDataPtr userData
         funPtr <- marshalOutHook callback
         getResult $ ucInsnHookAdd uc HookInsn funPtr userDataPtr begin end
                                   X86.Out
-    hoistEither result
 
 -- | Register a callback for a SYSCALL instruction hook event (X86).
 syscallHookAdd :: Storable a
@@ -147,13 +142,12 @@ syscallHookAdd :: Storable a
                -> Word64        -- ^ End address
                -> Emulator Hook -- ^ The hook handle on success, or an 'Error'
                                 -- on failure
-syscallHookAdd uc callback userData begin end = do
+syscallHookAdd uc callback userData begin end =
-    result <- lift . alloca $ \userDataPtr -> do
+    ExceptT . alloca $ \userDataPtr -> do
         poke userDataPtr userData
         funPtr <- marshalSyscallHook callback
         getResult $ ucInsnHookAdd uc HookInsn funPtr userDataPtr begin end
                                   X86.Syscall
-    hoistEither result
 
 -- | Register a callback for a valid memory access event.
 memoryHookAdd :: Storable a
@@ -167,12 +161,11 @@ memoryHookAdd :: Storable a
               -> Word64         -- ^ End address
               -> Emulator Hook  -- ^ The hook handle on success, or an 'Error'
                                 -- on failure
-memoryHookAdd uc memHookType callback userData begin end = do
+memoryHookAdd uc memHookType callback userData begin end =
-    result <- lift . alloca $ \userDataPtr -> do
+    ExceptT . alloca $ \userDataPtr -> do
         poke userDataPtr userData
         funPtr <- marshalMemoryHook callback
         getResult $ ucHookAdd uc memHookType funPtr userDataPtr begin end
-    hoistEither result
 
 -- | Register a callback for an invalid memory access event.
 memoryEventHookAdd :: Storable a
@@ -188,12 +181,11 @@ memoryEventHookAdd :: Storable a
                    -> Word64                -- ^ End address
                    -> Emulator Hook         -- ^ The hook handle on success, or
                                             -- an 'Error' on failure
-memoryEventHookAdd uc memEventHookType callback userData begin end = do
+memoryEventHookAdd uc memEventHookType callback userData begin end =
-    result <- lift . alloca $ \userDataPtr -> do
+    ExceptT . alloca $ \userDataPtr -> do
         poke userDataPtr userData
         funPtr <- marshalMemoryEventHook callback
         getResult $ ucHookAdd uc memEventHookType funPtr userDataPtr begin end
-    hoistEither result
 
 -- | Unregister (remove) a hook callback.
 hookDel :: Engine       -- ^ 'Unicorn' engine handle
@@ -202,9 +194,9 @@ hookDel :: Engine       -- ^ 'Unicorn' engine handle
 hookDel uc hook = do
     err <- lift $ ucHookDel uc hook
     if err == ErrOk then
-        right ()
+        pure ()
     else
-        left err
+        throwE err
 
 -------------------------------------------------------------------------------
 -- Helper functions

bindings/haskell/src/Unicorn/Internal/Core.chs

@@ -14,7 +14,7 @@ way cabal handles ordering of chs files.
 module Unicorn.Internal.Core where
 
 import Control.Monad
-import Control.Monad.Trans.Either (EitherT)
+import Control.Monad.Trans.Except (ExceptT)
 import Foreign
 
 {# context lib = "unicorn" #}
@@ -48,7 +48,7 @@ mkEngine ptr =
 
 -- | The emulator runs in the IO monad and allows for the handling of errors
 -- "under the hood".
-type Emulator a = EitherT Error IO a
+type Emulator a = ExceptT Error IO a
 
 -- | An architecture-dependent register.
 class Enum a => Reg a

bindings/haskell/unicorn.cabal

@@ -33,7 +33,6 @@ library
   build-depends:         base >=4 && <5
                        , bytestring >= 0.9.1
                        , transformers < 0.6
-                       , either >= 4.4
   hs-source-dirs:      src
   c-sources:           src/cbits/unicorn_wrapper.c
   include-dirs:        src/include