mirror of
https://github.com/yuzu-emu/unicorn.git
synced 2024-12-22 13:45:38 +00:00
Haskell bindings: use ExceptT instead of deprecated EitherT (#1034)
Backports commit 873fffc505b29c6179a8aece18b7e331e5f879e8 from unicorn.
This commit is contained in:
Brian McKenna
Lioncash
parent
9e8e5645fc
commit
07f315af47
|
|
@ -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
|
||||
hoistEither result
|
||||
return $ throwE err
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- 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
|
||||
hoistEither result
|
||||
return $ throwE err
|
||||
|
||||
-- | 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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
result <- lift . alloca $ \userDataPtr -> do
|
||||
codeHookAdd uc callback userData begin end =
|
||||
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
|
||||
result <- lift . alloca $ \userDataPtr -> do
|
||||
interruptHookAdd uc callback userData begin end =
|
||||
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
|
||||
result <- lift . alloca $ \userDataPtr -> do
|
||||
blockHookAdd uc callback userData begin end =
|
||||
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
|
||||
result <- lift . alloca $ \userDataPtr -> do
|
||||
inHookAdd uc callback userData begin end =
|
||||
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
|
||||
result <- lift . alloca $ \userDataPtr -> do
|
||||
outHookAdd uc callback userData begin end =
|
||||
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
|
||||
result <- lift . alloca $ \userDataPtr -> do
|
||||
syscallHookAdd uc callback userData begin end =
|
||||
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
|
||||
result <- lift . alloca $ \userDataPtr -> do
|
||||
memoryHookAdd uc memHookType callback userData begin end =
|
||||
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
|
||||
result <- lift . alloca $ \userDataPtr -> do
|
||||
memoryEventHookAdd uc memEventHookType callback userData begin end =
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue